************************************************************************ * MASTER MECHANISM V.3.0 ROUTINE NAME - DHF * * * * Purpose: * * Conversion of hydroxyketone into dihydrofuran * * * * INPUT: * * - rdct : name[a6]+formula[a120] of the species for which * * reaction with OH is considered * * - bond(i,j) : carbon-carbon bond matrix of chem * * - group(i) : groups at position (carbon) i * * - nring : min number of rings present * * - temp : reference temperature (more work on this needed) * * - cut_off : ratio below which a pathway is not considered * * - dbrch : NOT USED - MORE WORK ON THIS NEEDED * * - level : number of level (stable + radicals) that were * * necessary to produce the parent of rdct * * - stabl : number of stable level (no radical) that were * * necessary to produce the parent of rdct * * - nfn : total nb. of species having a fixed name * * - namfn(i) : table of the fixed name (6 character) * * - chemfn(i) : formula corresponding the ith species having a * * fixed name * * * * * * * * INPUT/OUTPUT * * - dict(j) : dictionnary line (name + formula + functional * * group info) of species number j * * - namlst(j) : name (lco=6 characters) of the species already * * used at position number j * * - nhldvoc : number of (stable) VOC in the stack * * - holdvoc(i) : list of the VOC in the stack * * - nhldrad : number of radical in the stack * * - holdrad(i) : list of the radicals in the stack * * * * * * * ************************************************************************ SUBROUTINE dhf_thf(rdct,bond,group,nring,brch, & dbrch,dict,namlst, & cut_off, & nhldvoc,holdvoc,nhldrad,holdrad,level,stabl, & nfn,namfn,chemfn,fdhf, & ncha,chatab) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'organic.h' INCLUDE 'common.h' * Input CHARACTER(LEN=lcf),INTENT(in) :: rdct CHARACTER(LEN=lgr),INTENT(in) :: group(mca) INTEGER,INTENT(in) :: bond(mca,mca) INTEGER,INTENT(in) :: nring REAL,INTENT(in) :: brch REAL,INTENT(in) :: cut_off * Input/output CHARACTER(LEN=ldi),INTENT(inout) :: dict(mni) REAL,INTENT(inout) :: dbrch(mni) CHARACTER(LEN=lco),INTENT(inout) :: namlst(mni) INTEGER,INTENT(inout) :: level INTEGER,INTENT(inout) :: stabl CHARACTER(LEN=lst),INTENT(inout) :: holdvoc(mlv) INTEGER,INTENT(inout) :: nhldvoc CHARACTER(LEN=lst),INTENT(inout) :: holdrad(mra) INTEGER,INTENT(inout) :: nhldrad INTEGER,INTENT(inout) :: nfn CHARACTER(LEN=lco),INTENT(inout) :: namfn(mfn) CHARACTER(LEN=lfo),INTENT(inout) :: chemfn(mfn) INTEGER,INTENT(inout) :: ncha CHARACTER(LEN=lco),INTENT(inout) :: chatab(10000) * output INTEGER,INTENT(out) :: fdhf * Internal CHARACTER(LEN=lfo) :: pchem(mnr,2) INTEGER :: ic, j, i, k,ia, igam,nca, ibet, nig INTEGER :: itr, or INTEGER :: l, m, n, rngflg, ring(mca) CHARACTER(LEN=lfo) :: pest(1), tempkc CHARACTER(LEN=lgr) :: tgroup(mca), pold, pnew INTEGER :: nr,np,nch,ich,j1,kk,ii,nc,ncd INTEGER :: tbond(mca,mca),flag(mnr), track(mco,mca) INTEGER :: nabcde(9), tabcde(9,mco,mca) REAL :: brtio REAL :: ratio(mnr) REAL :: tarrhc(mnr,3),rarrhc(3) INTEGER :: tempiflost INTEGER :: tempstabl CHARACTER*1 :: a1,a2,a3,a4 CHARACTER(LEN=lco) :: r(3), p(mnp) REAL :: s(mnp), ar1,ar2,ar3,f298,fratio INTEGER :: idreac, nlabel REAL :: xlabel,folow(3),fotroe(4) CHARACTER*1 :: fphase CHARACTER(LEN=lco) :: chaname,dhfname ! ---------- ! Initialize ! ---------- tempiflost=iflost IF(wtflag.NE.0) WRITE(*,*)'*dhf*' fdhf=0 ic=0 itr=0 igam=0 ia=0 ibet=0 nca=0 rngflg=0 or=0 nig=0 nr=0 DO i=1,mca IF (group(i)(1:1).NE.' ') nca=nca+1 ENDDO flag(:)=0 pchem(:,:)=' ' ratio(:)=0 tgroup(:) = group(:) tbond(:,:)=bond(:,:) tarrhc(:,:)=0. IF (nring.GT.0) RETURN ! Check the number of double bonds ncd=0 DO i=1,mca IF (tgroup(i)(1:2).EQ.'Cd') THEN ncd=ncd+1 ENDIF ENDDO IF (ncd.GT.2) RETURN ! ------------------------------- ! search for the right structure ! ------------------------------- DO ic=1,mca IF ( (INDEX(group(ic)(1:3),'CO ').NE.0) .OR. & (INDEX(group(ic)(1:4),'CHO ').NE.0) ) THEN ! search of an OH group in gamma ! check in the futur that both node does not belong to a cyle CALL abcde_map(bond,ic,nca,nabcde,tabcde) DO 456 itr=1,nabcde(4) igam=tabcde(4,itr,4) ia=tabcde(4,itr,2) ibet=tabcde(4,itr,3) IF ( (INDEX(group(igam),'(OH)').NE.0) .AND. & (group(igam)(1:2).NE.'CO') ) THEN ! find one ! ! Check if H atom in alpha of the carbonyl is available for dehydratation c IF (group(ia)(1:2).NE.'CH') GOTO 456 IF (group(igam)(1:1).NE.'C') GOTO 456 ! No ether function allowed c IF (group(ia)(1:3).EQ.'-O-') GOTO 456 c IF (group(ibet)(1:3).EQ.'-O-') GOTO 456 ! The group 'ia' can only have 'C' or 'H' c nig = INDEX(group(ia),' ') c DO i=1,(nig-1) c IF ((group(ia)(i:i).NE.'C') .AND. c & (group(ia)(i:i).NE.'H') .AND. c & (group(ia)(i:i).NE.'2') .AND. c & (group(ia)(i:i).NE.'3')) GOTO 456 c ENDDO ! Make the conversion only if ia and ibet are 'CH2' IF ((group(ia).NE.'CH2') & .OR.(group(ibet).NE.'CH2')) GOTO 456 ! If there's a ring with an ether function, the conversion can't occur DO i=1, mca CALL findring(i,ia,nca,bond,rngflg,ring) IF ((group(i)(1:3).EQ.'-O-').AND. & (ring(i).EQ.1)) THEN or=1 ENDIF IF ((rngflg.EQ.1).AND.(or.EQ.1)) GOTO 456 ENDDO ! make reaction nr = nr + 1 IF (nr.GT.mnr) THEN WRITE(6,'(a)') '--error--' WRITE(6,'(a)') 'from ROUTINE : dhf' WRITE(6,'(a)') 'too many reactions created for' WRITE(6,'(a)') rdct(lco+1:lcf) STOP ENDIF flag(nr) = 1 ! -------------------- ! make the DHF product ! -------------------- ! structure is change form RCO(1)-C2-C3-C4(OH)-R to ! RCd(1)=Cd(2)-C3-C4[-O-(nca+1)]-R ! group 1 (carbonyl to Cd) c PRINT *, 'OH présent' IF (group(ic)(1:2).eq.'CO') THEN pold = 'CO' pnew = 'Cd' ELSE IF (group(ic)(1:3).eq.'CHO') THEN pold = 'CHO' pnew = 'CdH' ENDIF CALL swap(group(ic),pold,tgroup(ic),pnew) ! group 2 (alpha to carbonyl) IF (group(ia)(1:3).eq.'CH2') THEN pold = 'CH2' pnew = 'CdH' ELSE IF (group(ia)(1:2).eq.'CH') THEN pold = 'CH' pnew = 'Cd' ENDIF CALL swap(group(ia),pold,tgroup(ia),pnew) ! group 4 (gamma to carbonyl bearing OH) pold = '(OH)' pnew = '' CALL swap(group(igam),pold,tgroup(igam),pnew) ! add group for -O- bond and create the bonds tgroup(nca+1)='-O-' tbond(nca+1,ic)=3 tbond(ic,nca+1)=3 tbond(igam,nca+1)=3 tbond(nca+1,igam)=3 tbond(ic,ia)=2 tbond(ia,ic)=2 ! rebuild, check and rename: CALL rebond(tbond,tgroup,pchem(nr,1),nring) CALL stdchm(pchem(nr,1)) c PRINT *, pchem(nr) ! restore tgroup tgroup(:) = group(:) tbond(:,:)= bond(:,:) ! -------------------- ! make the THF product ! -------------------- ! structure is change form RCO(1)-C2-C3-C4(OH)-R to ! RCHOH(1)-C2-C3-C4[-O-(nca+1)]-R ! group 1 (carbonyl to Cd) c PRINT *, 'OH présent' IF (group(ic)(1:2).eq.'CO') THEN pold = 'CO' pnew = 'C(OH)' ELSE IF (group(ic)(1:3).eq.'CHO') THEN pold = 'CHO' pnew = 'CH(OH)' ENDIF CALL swap(group(ic),pold,tgroup(ic),pnew) ! group 2 (alpha to carbonyl) ! IF (group(ia)(1:3).eq.'CH2') THEN ! pold = 'CH2' ! pnew = 'CdH' ! ELSE IF (group(ia)(1:2).eq.'CH') THEN ! pold = 'CH' ! pnew = 'Cd' ! ENDIF ! CALL swap(group(ia),pold,tgroup(ia),pnew) ! group 4 (gamma to carbonyl bearing OH) pold = '(OH)' pnew = '' CALL swap(group(igam),pold,tgroup(igam),pnew) ! add group for -O- bond and create the bonds tgroup(nca+1)='-O-' tbond(nca+1,ic)=3 tbond(ic,nca+1)=3 tbond(igam,nca+1)=3 tbond(nca+1,igam)=3 ! tbond(ic,ia)=2 ! tbond(ia,ic)=2 ! rebuild, check and rename: CALL rebond(tbond,tgroup,pchem(nr,2),nring) CALL stdchm(pchem(nr,2)) c PRINT *, pchem(nr) ! restore tgroup tgroup(:) = group(:) tbond(:,:)= bond(:,:) ENDIF 456 CONTINUE ENDIF ENDDO IF (nr.gt.0) fdhf=nr ! ------------------- ! Write the reaction !-------------------- ! assign a rate constant make THF DO i=1,nr ! tarrhc(i,1)=1.E+3 tarrhc(i,1)=1E-3 ! overwrited below -> write program later tarrhc(i,2)=0. tarrhc(i,3)=0. ratio(i)=1./nr ! since all channel all equal ENDDO ! flag down for duplicate products IF (nr.gt.1) THEN DO i=1,nr-1 DO j= i+1,nr IF (pchem(i,1).EQ.pchem(j,1)) THEN flag(i) = flag(i)+flag(j) flag(j) = 0 tarrhc(i,1) = tarrhc(i,1) + tarrhc(j,1) ratio(i)=ratio(i)+ratio(j) ENDIF ENDDO ENDDO ENDIF ich = 10 iflost=0 ! cancel potential C loss here but reset below DO 300 i=1,nr IF (flag(i).EQ.0) GOTO 300 ! 1-4 HC ---> CHA (1,4 hydroxy ketone to hydroxy tetrahydrofurans ! initialize reaction CALL rxinit3(a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) ich = ich + 1 IF (nch.GT.1) a4 = alfa(ich:ich) a1 = rdct(1:1) ar1=tarrhc(i,1) c ar1=1.E7*flag(i) ! overwrite c ar1=1.*flag(i) ! overwrite ar2=tarrhc(i,2) ar3=tarrhc(i,3) r(1) = rdct(1:lco) r(2) = ' ' r(3) = ' ' brtio = brch * ratio(i) c stabl=stabl-1 tempstabl=stabl-1 c tempstabl=stabl CALL bratio(pchem(i,2),brtio,p(1), & dbrch,dict,namlst, & nhldvoc,holdvoc,nhldrad,holdrad,level,tempstabl, & nfn,namfn,chemfn) s(1)=1. ! add the tetrahydrofuran (CHA) to the chat table ncha=ncha+1 IF (ncha.GT.10000) STOP 'max cha reached in dhf_thf' chatab(ncha)=p(1) chaname=p(1) f298=ar1 fratio=1. ! write out: reaction set as thermal reaction (idreac=0 and does ! not require labels) c CALL rxwrit3(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, c & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) c CALL rxwrit3(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, c & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) fphase='A' CALL rxwrit3wa(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) CALL rxwrit3wa(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) fphase='W' CALL rxwrit3wa(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) CALL rxwrit3wa(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) ! CHA ---> DHF (dihydration to dihydrofurans) ! initialize reaction CALL rxinit3(a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) ! ich = ich + 1 IF (nch.GT.1) a4 = alfa(ich:ich) a1 = p(1)(1:1) c ar1=tarrhc(i,1) c ar1=1E-3 ! Ziemann, PCCP, 2009 ar1=1E+7 ! conversion total ar2=tarrhc(i,2) ar3=tarrhc(i,3) r(1) = chaname r(2) = ' ' r(3) = ' ' brtio = brch * ratio(i) c stabl=stabl-1 tempstabl=stabl-1 c tempstabl=stabl CALL bratio(pchem(i,1),brtio,p(1), & dbrch,dict,namlst, & nhldvoc,holdvoc,nhldrad,holdrad,level,tempstabl, & nfn,namfn,chemfn) dhfname=p(1) s(1)=1. f298=ar1 fratio=1. ! write out: reaction set as thermal reaction (idreac=0 and does ! not require labels) c CALL rxwrit3(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, c & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) c CALL rxwrit3(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, c & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) fphase='A' CALL rxwrit3wa(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) CALL rxwrit3wa(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) fphase='W' CALL rxwrit3wa(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) CALL rxwrit3wa(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) ! DHF ---> CHA (hydration of dihydrofurans) ! initialize reaction CALL rxinit3(a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe) ! ich = ich + 1 IF (nch.GT.1) a4 = alfa(ich:ich) a1 = p(1)(1:1) ar1=1.E-7 ! neglige hydratation of DHF c ar1=0.15 ! Ziemann, PCCP 2009 for C13 ar2=tarrhc(i,2) ar3=tarrhc(i,3) r(1) = dhfname r(2) = ' ' r(3) = ' ' c tempstabl=stabl s(1)=1. p(1) = chaname f298=ar1 fratio=1. fphase='A' CALL rxwrit3wa(17,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) CALL rxwrit3wa(18,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlabel,xlabel,folow,fotroe, & fphase) 300 CONTINUE iflost=tempiflost ! reset iflost to the correct value ! end RETURN END