************************************************************************ * MASTER MECHANISM - ROUTINE NAME : prioty * * * * Updated: 04 March 2008, LISA * * * * PURPOSE: Check which formula in COPY has the highest priority, * * comparing the position of different functional groups and * * return the "standardized" formula * * * * If the chemical is a radical, the formulas remain where the ra- * * dical group is at the end of the formula. If there are still * * more than one writing left or the chemical is a non-radical mo- * * lecule, according to the group priorities, the formulas with the * * groups at the end remain, respectively. This is done for all * * functional groups in the molecule unless there are still more * * than one formulas left. * * * * INPUT: * * - group(i) : group at position (carbon) i * * - copy : buffer of all possible writing that must to be * * checked * * - ncp : number of formulae in copy * * - nring : number of separate rings in CHEM * * * * OUTPUT: * * - chem : standardized formula * ************************************************************************ SUBROUTINE prioty(group,rank,copy,ncp,nring,chem) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'organic.h' * input: CHARACTER(LEN=lfo) copy(mco) CHARACTER(LEN=lgr) group(mca) INTEGER ncp,nring INTEGER rank(mca) * output: CHARACTER(LEN=lfo) chem * internal: INTEGER i,j,ef(5) INTEGER cntr,nelim,high,priort(mco),ncg INTEGER k,gcntr,eflag,pos,ptr INTEGER rjg(mri,2),rjs(mri,2) CHARACTER(LEN=lgr) prigr LOGICAL lofind CHARACTER(LEN=lfo) tempcopy(mco) INTEGER temprjs(mco,mri,2), minrjc, maxrjc !print*,'*prioty*' !DO j = 1,10 !print*,'.. group, rank ..', group(j), rank(j) !ENDDO * -------------------------------------------------------- * initialize: * -------------------------------------------------------- DO i=1,lfo chem(i:i)=' ' ENDDO DO i=1,mco priort(i) = 0 ENDDO DO i = 1,5 ef(i) = 0 ENDDO * -------------------------------------------------------- * CHECK RADICAL * -------------------------------------------------------- * if different copies have different types of radicals, then * error... DO i=1,ncp IF (INDEX(copy(i),criegee).NE.0) THEN ef(1) = 1 ELSE IF (index(copy(i),acyl_peroxy).NE.0) THEN ef(2) = 1 ELSE IF (index(copy(i),alkyl_peroxy).NE.0) THEN ef(3) = 1 ELSE IF (index(copy(i),alkoxy).NE.0) THEN ef(4) = 1 ELSE ef(5) = 1 ENDIF ENDDO eflag = 0 DO i=1,5 eflag = eflag + ef(i) ENDDO IF(eflag.GT.1) THEN WRITE(6,'(a)') '--error--' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : prioty' WRITE(6,'(a)') 'different types of radicals for molecule:' WRITE(6,'(a)') chem STOP ENDIF * -------------------------------------------------------- * FUNCTIONAL GROUPS WERE ALREADY RATED AND ORDERED * -------------------------------------------------------- 20 CONTINUE * ----------------------------------------------------- * 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 ! loop ranks: don't expect to complete sequence DO j = 1,mca IF (rank(j).EQ.i) THEN prigr = group(j) !! DEBUG !! ! print*,'found group with rank',i,' ',prigr !! END DEBUG !! GO TO 201 ENDIF ENDDO 201 CONTINUE 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 and set priority (jump over the copy * already removed) DO 30 j = 1,ncp priort(j) = 0 pos=0 IF (copy(j)(1:1).eq.' ') GOTO 30 !! DEBUG !! ! print*,j,copy(j) !! END DEBUG !! ! remove ring-join characters if present IF(nring.GT.0) CALL rjsrm(nring,copy(j),rjs) * if the group exist more than once in the molecule, then find each * of them (thus the loop over gcntr). 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) THEN WRITE(6,*) 'From subroutine prioty' WRITE(6,*) 'problem to detect ',prigr(1:ncg) WRITE(6,*) 'in ',copy(j) STOP ENDIF 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+1).EQ.'-O').OR. & (copy(j)(pos+ncg:pos+ncg+2).EQ.'(-O').OR. & (copy(j)(pos+ncg:pos+ncg+2).EQ.')-O').OR. & (copy(j)(pos+ncg:pos+ncg+3).EQ.')(-O')) lofind=.true. IF (copy(j)(pos+ncg:pos+ncg).EQ.' ') lofind=.true. IF (.not.lofind) GOTO 17 priort(j) = priort(j) + priort(j) + pos ENDDO ! 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((priort(j).LT.high).AND.(priort(j).GT.0)) THEN copy(j) = ' ' IF(priort(j).GT.0) nelim = nelim + 1 IF (nelim.EQ.ncp-1) GO TO 500 !! DEBUG !! ! ELSE ! print*,i,j,priort(j),high,nelim ! print*,copy(j) !! END DEBUG !! ENDIF ENDDO 200 CONTINUE * If 2 rings with symmetrical shape, then no possibility to discriminate * among the remaining formula (eg in C12HCH2CH2CH2CH(C2H2)C1H2). In that * case, give priority to the formula having the largest position of * the first "ring joining character" ("1") in copy, then the second ... IF (nelim.ne.ncp-1) THEN IF (nring.ge.2) THEN * intialize and get ring joining character position DO i=1,ncp tempcopy(i)=' ' DO j=1,mri DO k=1,2 temprjs(i,j,k)=0 ENDDO ENDDO IF (copy(i)(1:1).ne.' ') THEN CALL rjsrm(nring,copy(i),rjs) tempcopy(i)=copy(i) DO j=1,mri DO k=1,2 temprjs(i,j,k)=rjs(j,k) ENDDO ENDDO CALL rjsadd(nring,copy(i),rjs) ENDIF ENDDO * check that all copies are identical (except ring joining character) DO i=1,ncp-1 IF ((tempcopy(i)(1:1).NE.' ').AND. & (tempcopy(i+1)(1:1).NE.' ')) THEN IF (tempcopy(i).NE.tempcopy(i+1)) THEN WRITE(6,'(a)') '--error--' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : prioty' WRITE(6,'(a)') 'different formula in copy:' WRITE(6,*) copy(i) WRITE(6,*) copy(i+1) STOP ENDIF ENDIF ENDDO * select the correct formula DO j=1,mri minrjc=lfo DO i=1,ncp ! minimum IF (copy(i)(1:1).NE.' ') THEN minrjc=MIN(temprjs(i,j,1),minrjc) ENDIF ENDDO DO i=1,ncp IF (temprjs(i,j,1).NE.minrjc) THEN IF (copy(i).NE.' ') THEN nelim=nelim+1 copy(i)=' ' ENDIF IF (nelim.EQ.ncp-1) GO TO 500 ENDIF ENDDO maxrjc=0 DO i=1,ncp ! maximum maxrjc=MAX(temprjs(i,j,2),maxrjc) ENDDO DO i=1,ncp IF (temprjs(i,j,2).NE.maxrjc) THEN IF (copy(i).NE.' ') THEN nelim=nelim+1 copy(i)=' ' ENDIF IF (nelim.EQ.ncp-1) GO TO 500 ENDIF ENDDO ENDDO ENDIF ENDIF 500 CONTINUE * --------------------------------------------------------- * check that only one copy remains and return * --------------------------------------------------------- IF(nelim.EQ.ncp-1) THEN DO i = 1,ncp IF (copy(i).NE.' ') chem = copy(i) ENDDO * too many formulae left ---> error: ELSE WRITE(6,'(a)') '--error--' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : prioty' WRITE(6,'(a)') 'more than one copy of the formula is left:' DO j=1,ncp WRITE(6,'(a)') copy(j) ENDDO STOP ENDIF * end of prioty IF(nring.GT.0) CALL rjgadd(nring,group,rjg) !WRITE(6,'(a)') 'output from prioty: ',chem !write( *, * ) 'Press Enter to continue' !read( *, * ) !print*,'*end prioty*' RETURN END