!*********************************************************************** * MASTER MECHANISM - ROUTINE NAME : STDCHM * * * * PURPOSE: - Standardize chemical formula of molecule * * * * INPUT/OUTPUT * * - chem : formula of species (on output chem is written * * in the standard form) * * * * The purpose of this subroutine is to avoid duplicates in the list * * of species. Therefore, chemical formula must be written * * in a unique way. * * * * First, the functional groups of the molecule are written in an * * array, GROUP, the bond-matrix is evaluated and the double-bond * * flag, DBFLG, is set, if there is a double-bond in CHEM. * * Then, the very longest tree in CHEM is evaluated after looking * * top-down and down-top. Each possible formula with the longest * * possible chain or most double-bonds in the chain is a new copy. * * All non-identical formulas for the molecule undergo a final * * check. The functional groups, which are attached to the chain or * * a carbon must have a predefined order. * * After all this rewriting and these checks there is only one * * possible formula for the molecule left. * * * * INPUT/OUTPUT : * * - chem : the formula of the species to be standardized * ************************************************************************ SUBROUTINE stdchm(chem) IMPLICIT NONE INCLUDE 'general.h' * input/output: CHARACTER(LEN=lfo),INTENT(inout) :: chem * local INTEGER :: cnum INTEGER :: onum INTEGER :: dbflg INTEGER :: bond(mca,mca) INTEGER :: path(mca,mca,mca) INTEGER :: clngth(mca,mca) INTEGER :: rjg(mri,2) CHARACTER(LEN=lgr) :: group(mca) LOGICAL :: lobond(mca,mca) CHARACTER(LEN=lfo) :: tchem, copy(mco) INTEGER :: nc, nca, nce, nl, pflag, nring INTEGER :: leaf, last, ptr, p, i, j, k, ncp INTEGER :: ig, pg, ng INTEGER :: locat INTEGER :: rank(mca) ! flag forces STOP after named species, for debuggind INTEGER :: flag * time estimate CHARACTER(LEN=10):: date,btime,etime REAL :: time_diff INCLUDE 'timecommon.h' CALL date_and_time(date,btime) * ------------------------------------------------------ * INITIALIZE * ------------------------------------------------------ !print*,"*stdchm* ",chem copy(:) = ' ' clngth(:,:) = 0 lobond(:,:) = .false. path(:,:,:) = 0 flag = 0 !! DEBUG: insert name & length of test species ! IF(chem(1:30).EQ."C12HCH2CH(C1(CH3)CH3)CH2CdH=Cd") flag = 1 !! END DEBUG !! * ------------------------------------------------------ * CHECK INPUT FORMULA AND MAKE BOND AND GROUP TABLES * ------------------------------------------------------ * get the number of >C< , >c< (nca) and -O- (nce) in the molecule nc = INDEX(chem,' ') - 1 nca = cnum(chem,nc) nce = onum(chem,nc) * lump >C<, >c< and -O- into nca nca=nca+nce * only multi-carbon molecules checked: IF (nca.LE.1) RETURN * check parenthesis:if open parenthesis,then stop the run. p = 0 DO i=1,nc IF(chem(i:i).EQ.'(') p = p + 1 IF(chem(i:i).EQ.')') p = p - 1 ENDDO IF(p.NE.0) THEN WRITE(6,'(a)') '--error-- 1' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : stdchm' WRITE(6,'(a)') 'parentheses mismatch in chemical formula:' WRITE(6,'(a)') chem STOP ENDIF * build the bond and group matrix CALL grbond(chem,nc,group,bond,dbflg,nring) * rank groups according to rating CALL ratings(nca,group,bond,nring,rank) ! IF RING EXISTS: rearrange according to rank, ! zero out 'broken' ring bonds IF(nring.GT.0) THEN CALL uniqring(nring,nca,group,bond,rank,rjg) DO k=1,nring i=rjg(k,1) j=rjg(k,2) bond(i,j) = 0 bond(j,i) = 0 ENDDO ENDIF * ------------------------------------------------------ * WRITE ALL POSSIBLE FORMULA OF THE SPECIES * ------------------------------------------------------ * make a logical copy of the bond matrix DO i=1,nca DO j=1,nca IF (bond(i,j).NE.0) lobond(i,j)= .true. ENDDO ENDDO * check that the functional groups are correctly sorted for each group DO i=1,nca locat=INDEX(group(i),')(') IF (locat.NE.0) CALL ckgrppt(locat,group(i)) ENDDO * find longest tree, top-down, starting with the first group CALL lntree(bond,dbflg,1,2,nca,clngth,path) * look down-top for the very longest tree ... ncp = 0 DO 50 i=1,nca IF (clngth(1,i).NE.0) THEN leaf = path(1,i,clngth(1,i)) last = path(1,i,clngth(1,i)-1) CALL lntree(bond,dbflg,leaf,last,nca,clngth,path) * write the formula of species according to the longest tree * in path. Each group are written in the formula with all the * branches by the mkcopy subroutine. The formula is written twice * for each longest tree, down-top and top-down by the revers subroutine. DO 55 j=1,nca IF (clngth(leaf,j).NE.0) THEN ncp=ncp+1 ptr = 1 DO k=1,nca ig = path(leaf,j,k) IF (ig.NE.0) THEN IF (k.GT.1) pg = path(leaf,j,k-1) IF (k.LT.nca) ng = path(leaf,j,k+1) !print*,'stdchm ',ig,pg,ng CALL mkcopy & (lobond,group,nca,rank,nring,ig,pg,ng,ptr,copy(ncp)) ENDIF ENDDO CALL revers(copy(ncp),copy(ncp+1)) ncp = ncp + 1 ENDIF 55 CONTINUE ENDIF 50 CONTINUE * ------------------------------------------------------ * COLLAPSE IDENTICAL FORMULA * ------------------------------------------------------ IF (ncp.GT.1) THEN nl = ncp DO 70 i=1,nl-1 j=i 76 j=j+1 IF (j.GT.nl) GOTO 70 IF (copy(i).EQ.copy(j)) THEN copy(j) = ' ' DO k=j,nl copy(k) = copy(k+1) ENDDO IF(copy(i).ne.' ') THEN ncp = ncp - 1 j = j - 1 ENDIF ENDIF GOTO 76 70 CONTINUE ENDIF IF (ncp.EQ.0) THEN WRITE(6,'(a)') '--error-- 1' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : stdchm' WRITE(6,'(a)') 'no copies of the formula are left' WRITE(6,'(a)') 'chemical formula=' WRITE(6,'(a)') chem STOP ENDIF * ------------------------------------------------------ * if more than one copy, get the standardized formula * ------------------------------------------------------ * subroutine prioty check group order and return the * standardized formula IF (ncp.EQ.1) THEN tchem = copy(1) ELSE CALL prioty(group,rank,copy,ncp,nring,tchem) ENDIF * write double bond IF (dbflg.NE.0) CALL dwrite(tchem) * check parenthesis of the standardized copy nc = INDEX(tchem,' ') - 1 p = 0 DO i=1,nc IF (tchem(i:i).EQ.'(') p = p + 1 IF (tchem(i:i).EQ.')') p = p - 1 ENDDO IF(p.NE.0) THEN WRITE(6,'(a)') '--error-- 2' WRITE(6,'(a)') 'from MASTER MECHANISM ROUTINE : stdchm' WRITE(6,'(a)') 'parentheses mismatch in chemical formula:' WRITE(6,'(a)') tchem STOP ENDIF * ------------------------------------------------------ * RETURN THE STANDARDIZED FORMULA * ------------------------------------------------------ chem = tchem !print*,'stdchm final version =',chem !! DEBUG !! IF(flag.EQ.1)STOP !! END DEBUG !! CALL date_and_time(date,etime) telstd=telstd+time_diff(btime,etime) RETURN END