************************************************************************ * MASTER MECHANISM - ROUTINE NAME : brpri * * * * * * PURPOSE: This routine is very similar to prioty. Main difference is * * that prioty is called to find the standardized formula of * * of the molecule while brpri is called to find which branch * * has the highest priority in the various copies. * * * * The subroutine check which formula of the branch in "copy" * * has the highest priority and return the corresponding index * * in "copy" * * * * INPUT: * * - group(i) : group at position (carbon) i * * - rank(i) : rank (priority) of group i (low = more important) * * - copy : buffer of all possible writing that need to be * * checked * * - ncp : number of formula in copy * * * * OUTPUT: * * - maxpri : index of the formula in copy having the highest * * priority * * * * -SEE PRIOTY FOR ADDITIONAL COMMENT - * * * ************************************************************************ SUBROUTINE brpri(group,rank,copy,ncp,nring,maxpri) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'organic.h' * input: INTEGER,INTENT(in) :: rank(mca) INTEGER,INTENT(in) :: ncp,nring CHARACTER(LEN=lgr),INTENT(in) :: group(mca) * input/output: CHARACTER(LEN=lfo),INTENT(inout):: copy(mca) * output: INTEGER,INTENT(out) :: maxpri * internal: INTEGER :: i,j,order(mca) INTEGER :: cntr,nelim,high,priort(mco),ncg INTEGER :: k,gcntr,pos,ptr INTEGER :: rjg(mri,2),rjs(mri,2) CHARACTER(LEN=lgr) :: prigr LOGICAL :: lofind * ----------------------------------------------------- * INITIALIZE * ----------------------------------------------------- !print*,'*brpri*' maxpri=0 priort(:) = 0 * ----------------------------------------------------- * GROUPS ALREADY RATED AND RANKED (ORDERED) * ----------------------------------------------------- * note : the group exist in the molecule but may not exist in the branch * => not all possible ranks may be present * ----------------------------------------------------- * FIND PRIORITY AND ELIMINATE SUCCESSIVELY THE FORMULA * ----------------------------------------------------- nelim = 0 * loop over the groups, starting with the highest priority group IF(nring.GT.0) CALL rjgrm(nring,group,rjg) DO 200 i = 1,mca DO j = 1,mca IF (rank(j).EQ.i) prigr = group(j) ENDDO ncg = INDEX(prigr,' ') - 1 * count the number of groups identical to prigr gcntr = 0 DO j = 1,mca IF (group(j).EQ.prigr) gcntr = gcntr + 1 ENDDO * loop over the copies of the branch and set priority. Here the * group may not be in the formula of the branch => jump to next copy DO 30 j = 1,ncp priort(j) = 0 IF (INDEX(copy(j),prigr(1:ncg)).eq.0) GOTO 30 pos=0 * remove ring-join characters if present IF(nring.GT.0) CALL rjsrm(nring,copy(j),rjs) * find the position of the group in the branch. Check that the group * was really found and not only a part of another group : e.g. CO in * CO(OH) or CdH in CdH2 DO k = 1, gcntr lofind=.false. 17 ptr=INDEX(copy(j)(pos+1:lfo),prigr(1:ncg)) IF (ptr.eq.0) GOTO 20 pos = pos + ptr IF ((copy(j)(pos+ncg:pos+ncg).EQ.'C').OR. & (copy(j)(pos+ncg:pos+ncg+1).EQ.'(C').OR. & (copy(j)(pos+ncg:pos+ncg+1).EQ.')C').OR. & (copy(j)(pos+ncg:pos+ncg+2).EQ.')(C')) lofind=.true. IF ((copy(j)(pos+ncg:pos+ncg).EQ.'c').OR. & (copy(j)(pos+ncg:pos+ncg+1).EQ.'(c').OR. & (copy(j)(pos+ncg:pos+ncg+1).EQ.')c').OR. & (copy(j)(pos+ncg:pos+ncg+2).EQ.')(c')) lofind=.true. IF ((copy(j)(pos+ncg:pos+ncg+2).EQ.')-O').OR. & (copy(j)(pos+ncg:pos+ncg+1).EQ.'-O')) lofind=.true. IF (copy(j)(pos+ncg:pos+ncg).EQ.' ') lofind=.true. IF (lofind) THEN priort(j) = priort(j) + priort(j) + pos ELSE GOTO 17 ENDIF ENDDO 20 CONTINUE ! replace ring-join characters if necessary IF(nring.GT.0) CALL rjsadd(nring,copy(j),rjs) 30 CONTINUE * find the maximum high = 0 DO j = 1,ncp high = MAX(priort(j),high) ENDDO * eliminate copy with priority < maximum (stop if 1 copy remain) DO j = 1,ncp IF (priort(j).LT.high) THEN IF (copy(j)(1:1).NE.' ') THEN copy(j) = ' ' nelim = nelim + 1 IF (nelim.EQ.ncp-1) GO TO 500 ENDIF ENDIF ENDDO 200 CONTINUE 500 CONTINUE * --------------------------------------------------------- * check that only one copy remains and return its ID number * --------------------------------------------------------- IF (nelim.EQ.ncp-1) THEN DO i = 1,ncp IF (copy(i)(1:1).NE.' ') maxpri=i ENDDO * too many formulae left ---> error: ELSE WRITE(6,'(a)') '--error--' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : brpri' WRITE(6,'(a)') 'more than one copy of the formula is left:' DO j=1,ncp WRITE(6,'(a)') copy(j) WRITE(99,*) 'brpri',copy(j) ENDDO c RETURN !STOP STOP ENDIF * end of brpri IF(nring.GT.0) CALL rjgadd(nring,group,rjg) RETURN END