* This subroutine defines the products of a ring-opening reaction. * It is assumed that the ring-opening is already done in the calling * program, by setting the corresponding element of BOND to zero * This subroutine expects to receive a bi-radical (e.g. R.-CO.) * with a bond matrix that makes sense (rejoin has already been called). * Reactions are the dominant pathway (only) from Calvert et al (2007) ! ! CREATED: Julia Lee-TAYLOR, NCAR *************************************************************************** SUBROUTINE openr(bond,group,nring,chem1,chem2,coprod) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'common.h' INCLUDE 'organic.h' * input INTEGER bond(mca,mca) CHARACTER(LEN=lgr) group(mca) INTEGER nring * output CHARACTER(LEN=lfo) chem1, chem2 CHARACTER(LEN=lco) coprod(mca) * internal INTEGER tbnd1(mca,mca), tbnd2(mca,mca) CHARACTER(LEN=lfo) tchem CHARACTER(LEN=lgr) tgrp1(mca),tgrp2(mca),pold,pnew,gold,gnew CHARACTER(LEN=lco) tcop(mca) INTEGER i,j,ii,jj,k,l, ia,ib,ic,ix,iy,iz INTEGER ncr,nrad,nca,ind INTEGER rngflg,ring(mca) CHARACTER(LEN=lfo) rdckprod(mca) CHARACTER(LEN=lco) rdcktprod(mca,mca) INTEGER nip REAL sc(mca) IF(wtflag.GT.0) WRITE(6,*) '*openr*' * Initialise nca = 0 ncr = 0 nrad = 0 chem1 = ' ' chem2 = ' ' tchem = ' ' ia = 0 ib = 0 ix = 0 iy = 0 iz = 0 ind= 0 DO i=1,mca coprod(i) = ' ' tcop(i) = ' ' tgrp1(i) = ' ' tgrp2(i) = ' ' DO j=1,mca tbnd1(i,j) = 0 tbnd2(i,j) = 0 ENDDO ENDDO * Count groups, identify radical groups (ia,iz) * Define iz as furthest right CO., or as * furthest right radical if no CO. exists * Define ia as 'other' radical, count groups DO i=1,mca IF(group(i).NE.' ') nca=i IF(INDEX(group(i),'.').NE.0) nrad=nrad+1 IF(INDEX(group(i),acyl).NE.0) iz = i ENDDO IF(iz.EQ.0)THEN DO i=nca,1,-1 IF(INDEX(group(i),'.').NE.0) iz = i ENDDO ENDIF * if other radical end is substituted with (OOH), (OH) or (ONO2), * perform decomposition, treat resulting single radical, * and return to calling program DO i=nca,1,-1 IF(INDEX(group(i),'.').NE.0.AND.i.NE.iz) THEN IF(INDEX(group(i),hydro_peroxide).NE.0 .OR. & INDEX(group(i),hydroxy).NE.0 .OR. & INDEX(group(i),nitrate).NE.0) THEN CALL oprad(group(i),tgrp1(i),coprod(i)) group(i)=tgrp1(i) CALL rebond(bond,group,tchem,nring) c CALL radchk(tchem,chem1,tcop) CALL radchk(tchem,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) chem1 = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca ind=0 DO k=j,nca IF(tcop(j)(1:1).NE.' '.AND.coprod(k)(1:1).EQ.' '.AND. & ind.EQ.0)THEN coprod(k)=tcop(j) ind=1 ENDIF ENDDO ENDDO RETURN ENDIF * otherwise, continue with cyclic bi-radical ia = i ENDIF ENDDO IF(nrad.LT.2)THEN print*,'ERROR in subroutine openr!' print*,'bi-radical not found' WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP ELSE IF(nrad.GT.2)THEN print*,'ERROR in subroutine openr!' print*,'too many radical centers' WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP ENDIF !troubleshooting !DO i=1,nca ! print*,group(i),(bond(i,j),j=1,nca) !ENDDO * Find which carbons were previously on ring bond(ia,iz)=1 bond(iz,ia)=1 CALL findring(ia,iz,nca,bond,rngflg,ring) bond(ia,iz)=0 bond(iz,ia)=0 * Find # of carbons previously on ring !print*,nca, nring DO i=1,nca IF(ring(i).EQ.1) ncr=ncr+1 ENDDO * identify groups in chain adjacent to radicals * ia = '.'; ib = ia+1; ix = ib+1; iz = 'CO.'; iy = iz-1 IF(iz.GT.ia)THEN DO i=iz-1,ia+1,-1 IF(ring(i).EQ.1) ib = i ENDDO DO i=ia+1,iz-1 IF(ring(i).EQ.1) iy = i ENDDO DO i=iy-1,ib+1,-1 IF(ring(i).EQ.1) ic = i ENDDO DO i=ib+1,iy-1 IF(ring(i).EQ.1) ix = i ENDDO ELSE DO i=ia-1,iz+1,-1 IF(ring(i).EQ.1) iy = i ENDDO DO i=iz+1,ia-1 IF(ring(i).EQ.1) ib = i ENDDO DO i=ib-1,iy+1,-1 IF(ring(i).EQ.1) ic = i ENDDO DO i=iy+1,ib-1 IF(ring(i).EQ.1) ix = i ENDDO ENDIF * ---------------------------------------- * a,b) bi-radical rearrangements (following photolysis of cyclic ketones) * Pathways given here are the dominant among several channels. * reference: Calvert et al, Chemistry of Alkanes (2007) * ---------------------------------------- IF(ncr.GE.6) THEN * C6+ =(a,b,c,x,y,z) =========================== !print*,ia,ib,ic,ix,iy,iz ! a) acyl-to-aldehyde rearrangement (CH_. at ia, CH/CH2 at ib, CO. at iz) IF(INDEX(group(iz),acyl).NE.0)THEN IF(INDEX(group(ia),'CH').NE.0.AND. $ INDEX(group(ib),'CH').NE.0)THEN !print*,'cC6: acyl-to-ketone rearrangement' pold=acyl pnew=aldehyde CALL swap(group(iz),pold,tgrp1(iz),pnew) group(iz)=tgrp1(iz) k=INDEX(group(ia),'.') group(ia)(3:k)=group(ia)(2:k-1) group(ia)(1:2)='Cd' IF(INDEX(group(ib),primary).EQ.1)THEN ! hydrogen is abstracted from ib group(ib)='CdH' ELSE group(ib)(1:2)='Cd' IF(INDEX(group(ib),'Cd(ONO2)').NE.0)THEN pold=nitrate pnew=alkoxy CALL swap(group(ib),pold,tgrp1(ib),pnew) group(ib)=tgrp1(ib) coprod(ib)='NO2 ' CALL rebond(bond,group,tchem,nring) ENDIF ENDIF bond(ia,ib)=2 bond(ib,ia)=2 CALL rebond(bond,group,tchem,nring) ! jettison leaving groups if appropriate CALL alkcheck(tchem,coprod(ia)) IF(INDEX(tchem,'.').NE.0)THEN c CALL radchk(tchem,chem1,tcop) CALL radchk(tchem,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) chem1 = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO CALL stdchm(chem1) ELSE chem1=tchem ENDIF DO i=1,nca IF(tcop(i).EQ.' ') coprod(ib)=tcop(i) ENDDO GO TO 900 ! b) CO elimination + new ring formation (for R.-C(O). if no H at both ia, ib) ELSE !print*,'cC6 : CO elimination' bond(ia,iy)=1 bond(iy,ia)=1 bond(iz,iy)=0 bond(iy,iz)=0 k=INDEX(group(ia),'.') group(ia)(3:k)=group(ia)(2:k-1) group(ia)(1:2)='C1' k=INDEX(group(iy),' ') group(iy)(3:k)=group(iy)(2:k-1) group(iy)(1:2)='C1' group(iz) = ' ' coprod(iz) = 'CO ' CALL rebond(bond,group,chem1,nring) IF(INDEX(chem1,'.').NE.0) THEN c CALL radchk(chem1,tchem,tcop) CALL radchk(chem1,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(ib)=tcop(j) ENDDO chem1=tchem CALL stdchm(chem1) ENDIF GO TO 900 ENDIF ENDIF print*,'ERROR in openr: C6 compound not found' DO i=1,nca print*,group(i) ENDDO !STOP WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP ELSE IF(ncr.EQ.5) THEN * C5 =(a,b,x,y,z)==================================== !print*,ia,ib,ix,iy,iz ! CO elimination and 2 x ethene formation (for R.-C(O).) IF(INDEX(group(iz),acyl).NE.0)THEN !print*,'cC5 : CO elimination' bond(iz,iy)=0 bond(iy,iz)=0 bond(iz,ia)=0 bond(ia,iz)=0 bond(ib,ix)=0 bond(ix,ib)=0 ! add radical dots (ia and iz are already radicals) DO j=1,3 IF(j.EQ.1)i=ib IF(j.EQ.2)i=ix IF(j.EQ.3)i=iy k=INDEX(group(i),' ') group(i)(k:k) = '.' ENDDO ! first fragment: ethene (ia=ib) IF(iz.GT.ia)THEN ! ia-ib is already at start of array DO i=1,ix-1 tgrp1(i)=group(i) DO j=1,ix-1 tbnd1(i,j)=bond(i,j) ENDDO ENDDO ii=ia jj=ib ELSE ! iz < ia : shift indices of 2nd half of molecule DO i=ib,nca ii=i-ib+1 tgrp1(ii)=group(i) DO j=ib,nca jj=j-ib+1 tbnd1(ii,jj)=bond(i,j) ENDDO ENDDO ii=ia-ib+1 jj=1 ENDIF ! make ethene DO j=1,2 IF(j.EQ.1)i=ii IF(j.EQ.2)i=jj k=INDEX(tgrp1(i),'.') tgrp1(i)(3:k)=tgrp1(i)(2:k-1) tgrp1(i)(1:2)='Cd' ENDDO tbnd1(ii,jj)=2 tbnd1(jj,ii)=2 CALL rebond(tbnd1,tgrp1,chem1,nring) ! jettison leaving groups if appropriate CALL alkcheck(chem1,coprod(ia)) IF(INDEX(chem1,'.').NE.0) THEN c CALL radchk(chem1,tchem,tcop) CALL radchk(chem1,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(ib)=tcop(j) ENDDO chem1=tchem ENDIF ! second fragment: ethene (ix=iy) IF(iz.GT.ia)THEN ! shift ix-iy to start of array DO i=ix,iz-1 ii=i-ix+1 tgrp2(ii)=group(i) DO j=ix,iz-1 jj=j-ix+1 tbnd2(ii,jj)=bond(i,j) ENDDO ENDDO ii=iy-ix+1 jj=1 ELSE ! iz < ia ; iz-iy is at start of array, shift 1 place to left DO i=2,ib-1 ii = i-1 tgrp2(ii)=group(i) DO j=2,ib-1 jj = j-1 tbnd2(ii,jj)=bond(i,j) ENDDO ENDDO jj=ix-iy+1 ii=1 ENDIF ! make ethene DO j=1,2 IF(j.EQ.1)i=ii IF(j.EQ.2)i=jj k=INDEX(tgrp2(i),'.') tgrp2(i)(3:k)=tgrp2(i)(2:k-1) tgrp2(i)(1:2)='Cd' ENDDO tbnd2(ii,jj)=2 tbnd2(jj,ii)=2 CALL rebond(tbnd2,tgrp2,chem2,nring) ! jettison leaving groups if appropriate CALL alkcheck(chem2,coprod(ix)) IF(INDEX(chem2,'.').NE.0) THEN c CALL radchk(chem2,tchem,tcop) CALL radchk(chem2,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(iy)=tcop(j) ENDDO chem2=tchem ENDIF ! third fragment: CO coproduct coprod(iz) = 'CO ' GO TO 900 ENDIF print*,'ERROR in openr: C5 compound not found' DO i=1,nca print*,group(i) ENDDO !STOP WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP ELSE IF(ncr.EQ.4) THEN * C4 =(a,b,y,z)==================================== !print*,ia,ib,iy,iz ! R.-C(O). fragments to ketene + ethene (Calvert et al.) IF(INDEX(group(iz),'CO.').NE.0)THEN !print*,'cC4 : ketene elimination' bond(iz,ia)=0 bond(ia,iz)=0 bond(iy,ib)=0 bond(ib,iy)=0 ! add radical dots (ia and iz are already radicals) DO j=1,2 IF(j.EQ.1)i=ib IF(j.EQ.2)i=iy k=INDEX(group(i),' ') group(i)(k:k) = '.' ENDDO ! ethene (ia=ib) IF(iz.GT.ia)THEN ! ia-ib is already at start of array DO i=1,iy-1 tgrp1(i)=group(i) DO j=1,iy-1 tbnd1(i,j)=bond(i,j) ENDDO ENDDO ii=ia jj=ib ELSE ! iz < ia : shift indices of 2nd half of molecule DO i=ib,nca ii=i-ib+1 tgrp1(ii)=group(i) DO j=1,iy-1 jj=i-ib+1 tbnd1(ii,jj)=bond(i,j) ENDDO ENDDO ii=ia-ib+1 jj=1 ENDIF ! ii = radical center, jj = other center from ring DO j=1,2 IF(j.EQ.1)i=ii IF(j.EQ.2)i=jj k=INDEX(tgrp1(i),'.') tgrp1(i)(3:k)=tgrp1(i)(2:k-1) tgrp1(i)(1:2)='Cd' ENDDO tbnd1(ii,jj)=2 tbnd1(jj,ii)=2 CALL rebond(tbnd1,tgrp1,chem1,nring) CALL alkcheck(chem1,coprod(ia)) IF(INDEX(chem1,'.').NE.0) THEN c CALL radchk(chem1,tchem,tcop) CALL radchk(chem1,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(ib)=tcop(j) ENDDO chem1=tchem ENDIF ! ketene (iy=iz=O) IF(iz.GT.ia)THEN ! shift iy-iz to start of array DO i=iy,nca ii=i-iy+1 tgrp2(ii)=group(i) DO j=iy,iz jj=i-iy+1 tbnd2(ii,jj)=bond(i,j) ENDDO ENDDO ii=nca-iy+1 jj=1 ELSE ! iz < ia ; iz-iy is already at start of array DO i=1,nca-ib+1 tgrp2(i)=group(i) DO j=1,iy-1 tbnd2(i,j)=bond(i,j) ENDDO ENDDO jj=iy ii=iz ENDIF DO j=1,2 IF(j.EQ.1)i=ii IF(j.EQ.2)i=jj k=INDEX(tgrp2(i),'.') tgrp2(i)(3:k)=tgrp2(i)(2:k-1) tgrp2(i)(1:2)='Cd' ENDDO tbnd2(ii,jj)=2 tbnd2(jj,ii)=2 CALL rebond(tbnd2,tgrp2,chem2,nring) CALL alkcheck(chem2,coprod(iy)) IF(INDEX(chem2,'.').NE.0) THEN c CALL radchk(chem2,tchem,tcop) CALL radchk(chem2,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(iz)=tcop(j) ENDDO chem2=tchem ENDIF GO TO 900 ENDIF print*,'ERROR in openr: C4 compound not found' DO i=1,nca print*,group(i) ENDDO WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP !STOP ELSE IF(ncr.EQ.3) THEN * C3 =(a,b,z)=================================== !print*,ia,ib,iz ! CO elimination and ethene formation (for R.-C(O). or C(O).-R.) IF(INDEX(group(iz),'CO.').NE.0)THEN !print*,'cC3 : CO elimination' bond(ia,ib)=2 bond(ib,ia)=2 bond(iz,ib)=0 bond(ib,iz)=0 ! add radical dot (ia and iz are already radicals) i=ib k=INDEX(group(i),' ') group(i)(k:k) = '.' DO j=1,2 IF(j.EQ.1)i=ia IF(j.EQ.2)i=ib k=INDEX(group(i),'.') group(i)(3:k)=group(i)(2:k-1) group(i)(1:2)='Cd' ENDDO CALL rebond(bond,group,chem1,nring) CALL alkcheck(chem1,coprod(ia)) IF(INDEX(chem1,'.').NE.0) THEN c CALL radchk(chem1,tchem,tcop) CALL radchk(chem1,rdckprod,rdcktprod,nip,sc) IF (nip.EQ.1) tchem = rdckprod(1) IF (nip.NE.1) STOP 'openr.f' DO j=1,mca tcop(j) = rdcktprod(1,j) ENDDO DO j=1,nca IF(tcop(j)(1:1).NE.' ') coprod(ib)=tcop(j) ENDDO chem1=tchem ENDIF group(iz) = ' ' coprod(iz) = 'CO ' GO TO 900 ENDIF print*,'ERROR in openr: C3 compound not found' DO i=1,nca print*,group(i) ENDDO WRITE(99,*) 'openr',(group(i),i=1,nca) !STOP ENDIF 900 CONTINUE IF(chem2(1:3).EQ.'CO ')THEN chem2(1:3)=' ' coprod(nca+1)(1:3)='CO ' ENDIF ! troubleshooting !IF(wtflag.NE.0)THEN ! print*,'chem1',chem1 ! IF(INDEX(chem2(1:1),' ').EQ.0)print*,'chem2',chem2 ! DO i=1,nca+1 ! IF(INDEX(coprod(i)(1:1),' ').EQ.0)print*,i,coprod(i) ! ENDDO !ENDIF RETURN END