c-----------------------------------------------------------------------
      SUBROUTINE RGROUP(NATOM,NATC,NRES,NGRP,IPRES,LBRES,IGRAPH,ISYMBL,
     +                  ITREE,IGROUP,WEIT,XC,KONST,BELLY,nfu)
C
C************************************************************************
C                              AMBER                                   **
C                                                                      **
C                  Copyright (c) 1986, 1991, 1995                      **
C             Regents of the University of California                  **
C                       All Rights Reserved.                           ** 
C                                                                      **
C  This software provided pursuant to a license agreement containing   **
C  restrictions on its disclosure, duplication, and use. This software **
C  contains confidential and proprietary information, and may not be   **
C  extracted or distributed, in whole or in part, for any purpose      **
C  whatsoever, without the express written permission of the authors.  **
C  This notice, and the associated author list, must be attached to    **
C  all copies, or extracts, of this software. Any additional           **
C  restrictions set forth in the license agreement also apply to this  **
C  software.                                                           **
C************************************************************************
C
#ifdef DPREC 
      implicit double precision (a-h,o-z)
#endif
c
c     Mods for Rev A by gls:
c     - cpp selectable precision
c     - wildcard functionality fixed. (see findp)
c     - format change to print less garbage
c     - unreferenced statement labels removed
c     - changed title write from 12 to 19 A4. (not 20 to avoid wraps)
c     - changed to read from unit nf -- dac 12/90
c
      LOGICAL KONST,MISC,BELLY
C
C     ----- READ IN GROUPS EACH ATOM IS IN -----
C
C           WILL KEEP READING IN GROUPS OF CARDS UNTIL A BLANK CARD IS
C           READ
C           ALL ATOMS IN THIS CARD GROUP WILL BE PUT IN THE SAME GROUP
C           THE ONLY EXCEPTION IS A RES CARD WHICH STARTS WITH A -
C           RES NO. THE RESIDUES IN THIS GROUP WILL ALL BE PUT IN INDIV.
C           GROUPS ANY OTHER GROUPS IN THIS SECTION MUST ALSO START
C           WITH A  I.E. THEY MUST ALSO BE INDIV. GROUPS
C           ANY TIME A "FIND" CARD IS READ, ONLY THOSE ATOMS THAT MEET
C           THE SPECIFICATIONS ON AT LEAST 1 OF THE FIND CARDS
C           WILL BE INCLUDED IN THE GROUP
C           THIS OPTION MAY BE ENDED BY READING IN "NFIND",TERMINATING
C           THE INPUT FOR THE GROUPS, OR BY READING IN ANOTHER "FIND"
C
      COMMON/PROPF/JGRAPH(11),JRESNM(11),JSYMBL(11),JTREE(11),ISRCH
      DIMENSION ITITL1(20)
C
      DIMENSION IPRES(*),IGROUP(*),WEIT(*),IGRP(8),JGRP(8)
      DIMENSION LBRES(*),IGRAPH(*),ISYMBL(*),ITREE(*),XC(*)
      DIMENSION IFLD(20),JFLD(20),IHOL(20),IVAR(20),FVAR(20)
C
      DATA IFLD/ 2*0, 13*2 , 5*0 /
      DATA JFLD/ 4*1, 16*0 /
      DATA KATN /4HATOM /
      DATA IFIND /4HFIND /
      DATA NFIND /4HNFIN /
      DATA IIEND /4HEND /
      DATA KSEAR /4HSEAR/
C
C     ----- RES CARD LISTS RESIDUE GROUPS IGRP(I) TO JGRP(I) ----
C
C           IF 1ST VALUE IS NEGATIVE, THEN EVERY RESIDUE FROM IGRP(I)
C           TO JGRP(I) IS CONSIDERED A SEPARATE GROUP
C           IF 2ND VALUE   = 0, THEN SUBGROUP CONSISTS OF 1 RESIDUE
C           ATOM CARD READS IN GROUPS OF ATOMS
C           IF 2ND ATOM IN EACH PAIR  = 0 , THEN SUBGROUP CONSISTS OF
C           1 ATOM RES AND ATOM CARDS MAY BE READ IN ANY ORDER
C           END INPUT WITH AN "END " CARD
C
C           ZERO NGRP BEFORE CALLING THIS ROUTINE
C           ROUTINE WILL RETURN WITH THE NUMBER OF THE LAST GROUP READ
C
      NGRP = 0
      nf = nfu
      if (nf.le.0) nf=5
C
C     ----- INITIALISE THE GROUP ARRAY -----
C
      DO 100 I = 1,NATOM
        IGROUP(I) = 0
        IF (KONST) WEIT(I) = 0.0d0
  100 CONTINUE
   22 CONTINUE
        ITIME = 0
        LSIGN = 0
        IZERO = 0
        ISRCH = 0
        NATMG = 0
C
C       ----- READ DIFFERENT GROUPS -----
C
        READ(nf,9208) (ITITL1(K),K=1,19)
        IF(ITITL1(1).EQ.IIEND) then
          write(6, '(4x,a)') '----- END OF GROUP READ -----'
          GO TO 900
        endif
        NGRP = NGRP+1
        write(6,'(4x,a,i5,a)') '----- READING GROUP ',
     +                       ngrp, '; TITLE:'
        WRITE(6,9218) (ITITL1(K),K=1,19)
C
C       ----- IF CONSTRAINED GROUPS READ THE WEIGHT FOR EACH GROUP -----
C
        IF (KONST) then
          IFLD(1) = 3
          IFLD(2) = 0
          CALL RFREE(IFLD,IHOL,IVAR,FVAR,nf,6)
          WT = FVAR(1)
          WRITE(6,9018) NGRP,WT
        endif
   10   CONTINUE
C
C       ----- READ THE GROUP CARDS -----
C
        IFLD(1) = 1
        IFLD(2) = 2
        CALL RFREE(IFLD,IHOL,IVAR,FVAR,nf,6)
        KTYPG = IHOL(1)
        K = 1
        DO 120 I = 1,7
          IGRP(I) = IVAR(K)
          JGRP(I) = IVAR(K+1)
          K = K+2
  120   CONTINUE
        IF (KTYPG.EQ.IIEND) GO TO 16
        IF (KTYPG.EQ.NFIND) then
          WRITE(6,199)
          ISRCH = 0
          GO TO 10
        endif
        IF (KTYPG.eq.IFIND) then
C
C         ----- FIND OPTION ... READ THE ATOM SPECIFICS -----
C
          WRITE(6,200)
          DO 64 III = 1,12
            CALL RFREE(JFLD,IHOL,IVAR,FVAR,nf,6)
            JGRAPH(III) = IHOL(1)
            JSYMBL(III) = IHOL(2)
            JTREE(III) = IHOL(3)
            JRESNM(III) = IHOL(4)
            IF(JGRAPH(III).EQ.KSEAR) GO TO 65
            WRITE(6,202) JGRAPH(III),JSYMBL(III),JTREE(III),JRESNM(III)
   64     CONTINUE
   65     CONTINUE
C
          ISRCH = III-1
          IF(ISRCH.GT.10) WRITE(6,66) ISRCH
C
C         ----- NOW READ IN RES AND ATOMS TO BE SEARCHED -----
C
          GO TO 10
        endif
        ITIME = ITIME+1
        IF (KTYPG.ne.KATN) then
C
C         ----- 1ST GROUP OF 1ST CARD MUST BE - IF ANY - NUMBERS ARE
C               FOUND -----
C
          IF(ITIME.EQ.1.AND.IGRP(1).LT.0) LSIGN = 1
          DO 12 I = 1,7
            I1 = IGRP(I)
            IF (I1.EQ.0) GO TO 10
            I2 = JGRP(I)
            IF(I2.GT.NRES) I2 = NRES
            IF(I1.GT.0.AND.LSIGN.EQ.1) GO TO 36
            IF(I1.LT.0.AND.LSIGN.EQ.0) GO TO 36
            IF(I1.LT.0) I1 = -I1
            IF(I2.LE.0) I2 = I1
            IF(LSIGN.EQ.0) WRITE(6,14) NGRP,I1,I2
            DO 13 J = I1,I2
              ISTART = IPRES(J)
              IEND = IPRES(J+1)-1
              DO 45 K = ISTART,IEND
                IF (ISRCH.GT.0) 
     +            CALL FINDP(K,J,LFIND,NRES,IPRES,LBRES,ISYMBL,
     +                       ITREE,IGRAPH)
                IF (ISRCH.GT.0.AND.LFIND.EQ.0) GO TO 45
                IGROUP(K) = NGRP
                IF(KONST) WEIT(K) = WT
                NATMG = NATMG+1
   45         CONTINUE
              IF(LSIGN.EQ.1) WRITE(6,46) NGRP,J
              IF(LSIGN.EQ.1) NGRP = NGRP+1
   13       CONTINUE
   12     CONTINUE
          GO TO 10
        endif
C
C       ----- ATOM TYPE CONSTRAINTS -----
C
        IF(LSIGN.EQ.1) GO TO 36
        WRITE(6,51) NGRP
        DO 17 I = 1,7
          I1 = IGRP(I)
          IF(I1.LT.0) GO TO 36
          IF(I1.EQ.0) GO TO 10
          I2 = JGRP(I)
          IF(I2.GT.NATOM) I2 = NATOM
          IF(I2.LE.0) I2 = I1
          WRITE(6,52) I1,I2
          DO 18 J = I1,I2
            IF(ISRCH.GT.0) 
     +        CALL FINDP(J,IZERO,LFIND,NRES,IPRES,LBRES,ISYMBL,
     +                   ITREE,IGRAPH)
            IF(ISRCH.GT.0.AND.LFIND.EQ.0) GO TO 18
            NATMG = NATMG+1
            IGROUP(J) = NGRP
            IF(KONST) WEIT(J) = WT
   18     CONTINUE
   17   CONTINUE
        GO TO 10
C
   16   IF(LSIGN.EQ.1) NGRP = NGRP-1
        IF(ITIME.EQ.0) NGRP = NGRP-1
c       IF(ISRCH.GT.0) WRITE(6,199)
        WRITE(6,222) NATMG
      GO TO 22
C
   36 CONTINUE
      WRITE(6,127) KTYPG,(IGRP(I),JGRP(I),I = 1,7)
      GO TO 10
C
C     ----- ALL GROUPS ARE READ RETURN -----
C
  900 CONTINUE
      IF (KONST) then
C
C       ----- GATHER ALL THE CONSTRAINED ATOMS TOGETHER -----
C
        NATC = 0
        DO 920 I = 1,NATOM
          IF(IGROUP(I).LE.0) GO TO 920
          NATC = NATC+1
          IGROUP(NATC) = I
          WEIT(NATC) = WEIT(I)
  920   CONTINUE
C
C       ----- do not PRINT THE HISTORY OF CONSTRAINED ATOMS -----
C
#ifdef debug
        WRITE(6,9108)
        DO 940 I = 1,NATC
          J = IGROUP(I)
          J3 = 3*J-3
          WRITE(6,9118) I,J,IGRAPH(J),ISYMBL(J),ITREE(J),
     +                  (XC(J3+K),K=1,3), WEIT(I)
  940   CONTINUE
#endif
      else if (.not.BELLY) then
C
C       ----- PUT THE ATOMS WHICH ARE NOT IN THE DEFINED GROUPS
C             AS THE LAST GROUP -----
C
        MISC = .FALSE.
        DO 820 I = 1,NATOM
          IF(IGROUP(I).NE.0) GO TO 820
          MISC = .TRUE.
          IGROUP(I) = NGRP+1
  820   CONTINUE
        IF(MISC) NGRP = NGRP+1
c       IF(MISC) WRITE(6,9308) NGRP
      endif
*  11 FORMAT(A4,1X,7(2I5))
  199 FORMAT(1H ,5X,'END OF ATOM SPECIFICATION',/)
  200 FORMAT(1H ,5X,'ALL ATOMS THAT MEET 1 OF THE FOLLOWING',
     +    ' SPECIFICATIONS WILL BE INCLUDED IN GROUP BELOW',/)
*  61 FORMAT(A4,A2,A1,A4)
  202 FORMAT(1H ,5X,'GRAPH NAME  = ',A4,2X,'SYMBOL  = ',A2,4X,
     +        'TREE SYMBOL  = ',A1,5X,'RESIDUE TYPE  = ',A4,/)
   66 FORMAT(1H ,5X,'**** NUMBER OF FIND CARDS  = ',I5,2X,
     +        'IS TOO BIG ******',/)
   14 FORMAT(' GRP',I5,' RES',I5,' TO ',I5)
   46 FORMAT(1H ,5X,'GROUP',I5,3X,'CONSISTS OF RESIDUE',I5,/)
   51 FORMAT(1H ,5X,'GROUP',I5,3X,'CONSISTS OF ATOMS -',/)
   52 FORMAT(1H ,34X,I5,2X,'TO',I5)
  222 FORMAT(1H ,5X,'Number of atoms in this group  = ',I5)
  127 FORMAT(1H ,5X,'***PROBLEMS WITH GROUP',A4,14I5,'*******',/)
 9018 FORMAT(/5X,'GROUP',I5,' HAS HARMONIC CONSTRAINTS',F12.5)
 9118 FORMAT(I5,I6,1X,A4,1X,2A4,3F10.4,F12.5)
 9108 FORMAT(/ /10X,'HISTORY OF CONSTRAINED ATOMS',/ /)
 9208 FORMAT(20A4)
 9218 FORMAT(1X,20A4)
c9308 FORMAT(/5X,'THE GROUP ',I4, ' CONTAINS ALL ATOMS NOT DEFINED',
c    +       ' AS GROUPS BY THE INPUT',/)
      RETURN
      END
c-----------------------------------------------------------------------
      SUBROUTINE FINDP(IATOM,IRES,ILOC,NRES,IPRES,LBRES,ISYMBL,ITREE,
     +                 IGRAPH)
C
C************************************************************************
C                              AMBER                                   **
C                                                                      **
C                  Copyright (c) 1986, 1991, 1995                      **
C             Regents of the University of California                  **
C                       All Rights Reserved.                           ** 
C                                                                      **
C  This software provided pursuant to a license agreement containing   **
C  restrictions on its disclosure, duplication, and use. This software **
C  contains confidential and proprietary information, and may not be   **
C  extracted or distributed, in whole or in part, for any purpose      **
C  whatsoever, without the express written permission of the authors.  **
C  This notice, and the associated author list, must be attached to    **
C  all copies, or extracts, of this software. Any additional           **
C  restrictions set forth in the license agreement also apply to this  **
C  software.                                                           **
C************************************************************************
C
#ifdef DPREC 
      implicit double precision (a-h,o-z)
#endif
c     Rev A mod (G. Seibel, Apr 89)
c     Changed iblank, jblank to iwild, jwild, to give the wildcard
c     functionality promised by the doc.
c     isymbl() dimensioned. (this was long-standing bug)
C
      COMMON/PROPF/JGRAPH(11),JRESNM(11),JSYMBL(11),JTREE(11),ISRCH
      DIMENSION IPRES(*),LBRES(*),ITREE(*),IGRAPH(*),isymbl(*)
C
C     ----- CHECKS IF A GIVEN ATOM HAS CERTAIN CHARACTERISTICS -----
C
      DATA iwild /4H*   /
      DATA jwild /2H* /
C
      ILOC = 0
      IF(IRES.EQ.0) CALL FINDRS(IATOM,IRES,NRES,IPRES)
      DO 10 I = 1,ISRCH
        IF((JRESNM(I).NE.iwild).AND.(JRESNM(I).NE.LBRES(IRES)))
     +                GO TO 10
        IF((JGRAPH(I).NE.iwild).AND.(JGRAPH(I).NE.IGRAPH(IATOM)))
     +                GO TO 10
        IF((JTREE(I).NE.jwild).AND.(JTREE(I).NE.ITREE(IATOM)))
     +                GO TO 10
        IF((JSYMBL(I).NE.jwild).AND.(JSYMBL(I).NE.ISYMBL(IATOM)))
     +                GO TO 10
        ILOC = 1
        GO TO 20
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
c-----------------------------------------------------------------------
      SUBROUTINE FINDRS(NUMA,IRES,NRES,IPRES)
C
C************************************************************************
C                              AMBER                                   **
C                                                                      **
C                  Copyright (c) 1986, 1991, 1995                      **
C             Regents of the University of California                  **
C                       All Rights Reserved.                           ** 
C                                                                      **
C  This software provided pursuant to a license agreement containing   **
C  restrictions on its disclosure, duplication, and use. This software **
C  contains confidential and proprietary information, and may not be   **
C  extracted or distributed, in whole or in part, for any purpose      **
C  whatsoever, without the express written permission of the authors.  **
C  This notice, and the associated author list, must be attached to    **
C  all copies, or extracts, of this software. Any additional           **
C  restrictions set forth in the license agreement also apply to this  **
C  software.                                                           **
C************************************************************************
C
      DIMENSION IPRES(*)
C
      IF(NUMA.LE.0) GO TO 11
      IF(NUMA.GE.IPRES(NRES)) IRES = NRES
      IF(NUMA.GE.IPRES(NRES)) RETURN
      IM = NRES-1
      DO 10 I = 1,IM
        IF(NUMA.GE.IPRES(I).AND.NUMA.LT.IPRES(I+1)) GO TO 12
   10 CONTINUE
   11 WRITE(6,100) NUMA
      GO TO 200
   12 IRES = I
      RETURN
  200 CONTINUE
  100 FORMAT(/2x,'PROBLEMS FINDING RESIDUE OF ATOM ',I5)
      call mexit(6, 1)
      END
