************************************************************************ * MASTER MECHANISM - ROUTINE NAME : rxwrit3 * * * * PURPOSE: - write the reaction to a file in a standard format * * * * INPUT * * lout : unit number for the output file (where the reaction * * must be written) * * a1 : comment col. 1 (usually type of reaction) * * a2 : comment col. 2 (usually on/off switch) * * a3 : comment col. 18 (usually arrow or split counter) * * a4 : comment col. 19 (usually reaction channel letter) * * r(3) : array of reagents * * s(mnp) : array of stoichiometry coefficients * * p(mnp) : array of products * * ar1 : first arrhenius coefficient * * ar2 : second arrhenius coefficient (power in T) * * ar3 : third arrhenius coefficient (Ea/T) * * f298 : rate constant at 298 K (for the "full" reaction) * * fratio : branching ratio for the given rection at 298 K * * idreac : ID for the type of reaction (thermal, HV, EXTRA, M ...) * * nlab : label if the reaction is not thermal * * xlab : weighting factor for HV reaction * * folow : low pressure fall off arrhenius coefficient * * fotroe : troe parameter for fall off reaction * * * * OUTPUT : none * * * * NOTE : variable a1, a2, a3 and a4 are not used anymore (but kept * * since it might be required for the NCAR box model and for * * utilities). * * * * This subroutine computes the number of required splits (npmax * * products per line), adjusts stoichiometry coefficients and rate * * constants accordingly, collapses identical products and blanks out * * unity stoichiometry coefficients * * * * ID number are : * * 0 => simple thermal reaction * * 1 => HV reaction * * 2 => EXTRA reaction * * 3 => Fall Off reaction * ************************************************************************ SUBROUTINE rxwrit3wa(lout,a1,a2,a3,a4,r,s,p,ar1,ar2,ar3, & f298,fratio,idreac,nlab,xlab,folow,fotroe, & fphase) IMPLICIT NONE INCLUDE 'general.h' INCLUDE 'common.h' * maximum number of product in a single reaction before splitting INTEGER npmax PARAMETER (npmax=4) * input CHARACTER*1 a1,a2,a3,a4 CHARACTER(LEN=lco) r(3), p(mnp) REAL s(mnp),ar1,ar2,ar3,f298,fratio INTEGER lout, idreac, nlab REAL xlab,folow(3),fotroe(4) CHARACTER*1 fphase * internal CHARACTER*1 c1,c2,sign(mnp) CHARACTER(LEN=lco) p1(mnp), p2(mnp) REAL s1(mnp), s2(mnp) CHARACTER(LEN=6) charstoi(mnp) INTEGER nsplit REAL rc1 INTEGER i,j,k,np,j1,j2,jj CHARACTER(LEN=7) rg(3),pg(mnp) LOGICAL locheck ! remove the product if flag to stop chemistry is raised IF (iflost.eq.1) THEN DO i=1,mnp s(i)=0. p(i)=' ' ENDDO s(1)= real(xxc) p(1)= 'XCLOST' ENDIF * clean table of products and stoe coef (just in case) DO i=1,mnp IF (s(i).EQ.0.) p(i) = ' ' IF (p(i)(1:1).EQ.' ') s(i) = 0. ENDDO * duplicate variables which may get changed (i.e. preserve output) * and initialize rc1 = ar1 DO i=1,mnp sign(i) = ' ' charstoi(i) = ' ' pg(i) = ' ' s1(i) = s(i) p1(i) = p(i) p2(i) = ' ' s2(i) = 0. ENDDO * collapse identical products: DO i =1,mnp-1 IF (p1(i)(1:1).NE.' ') THEN DO j=i+1,mnp IF (p1(j).EQ.p1(i)) THEN s1(i) = s1(i) + s1(j) p1(j) = ' ' s1(j) = 0. ENDIF ENDDO ENDIF ENDDO * remove blank products and count distinct products. Data are stored * in s2 and p2. np = 0 DO i=1, mnp IF (p1(i).NE.' ') THEN np = np + 1 s2(np) = s1(i) p2(np) = p1(i) ENDIF ENDDO * in most cases the number of products is less than npmax. Assume first * that splitting corrections are not needed and modify if necessary. * If keyword EXTRA is used (id=2), then the reaction must hold with * 6 products (or change the program). If keyword HV is used (id=1),then * divide the weighting factor accordingly. nsplit=1 IF (np.gt.npmax) THEN nsplit = (np-1)/npmax + 1 DO i=1,np s2(i) = s2(i)*FLOAT(nsplit) ENDDO IF (idreac.eq.0) rc1 = rc1/FLOAT(nsplit) IF (idreac.eq.1) xlab = xlab/FLOAT(nsplit) IF (idreac.ge.2) THEN WRITE(6,*) '--error--, in rxwrit3. Idreac is equal 2 (EXTRA)' WRITE(6,*) 'but the number of reaction products exceed npmax' WRITE(6,*) 'np=',np,'for :' WRITE(6,'(a)') rg(1),c1,rg(2),c2,rg(3),' =>' STOP ENDIF ENDIF * transcribe stoichiometry coefficients to character string, blanking * out unity values: DO i=1,np WRITE(charstoi(i),'(F6.3)') ABS(s2(i)) IF (s2(i).EQ.0.) charstoi(i) = ' ' IF (s2(i).EQ.1.) charstoi(i) = ' ' ENDDO * put a "G" (for gas phase) at the beginning of each name, expect * for keywords : DO i=1,3 rg(i)=' ' IF (r(i)(1:1).ne.' ') THEN locheck=.false. IF (r(i)(1:4).eq.'(+M)') locheck=.true. IF (r(i)(1:2).eq.'M ' ) locheck=.true. IF (r(i)(1:3).eq.'HV ' ) locheck=.true. IF (r(i)(1:6).eq.'EXTRA ' ) locheck=.true. IF (r(i)(1:6).eq.'OXYGEN' ) locheck=.true. IF (r(i)(1:4).eq.'PERO' ) locheck=.true. IF (r(i)(1:6).eq.'MEPERO' ) locheck=.true. IF (r(i)(1:6).eq.'ISOM ' ) locheck=.true. IF (locheck) THEN rg(i)(1:6)=r(i) ELSE rg(i)(1:1)=fphase rg(i)(2:7)=r(i) ENDIF ENDIF ENDDO DO i=1,np IF (p2(i).ne.' ') THEN locheck=.false. IF (p2(i)(1:4).eq.'(+M)') locheck=.true. IF (p2(i).eq.'EMPTY ') locheck=.true. IF (locheck) THEN pg(i)(1:6)=p2(i) IF (p2(i).eq.'EMPTY ') pg(i)='NOTHING' ELSE pg(i)(1:1)=fphase pg(i)(2:7)=p2(i) ENDIF ENDIF ENDDO * add the sign '+' between reactants c1=' ' c2=' ' IF ( (r(2).NE.' ') .AND. (r(2)(1:1).NE.'(') ) c1='+' IF ( (r(3).NE.' ') .AND. (r(3)(1:1).NE.'(') ) c2='+' * add the sign '+' between products DO i=2,np j=i-1 IF (p2(i).ne.' ') THEN IF (s2(i).lt.0.) THEN sign(j)='-' ELSE IF (p2(i)(1:5).NE.'(+M)') sign(j)='+' ENDIF ENDIF ENDDO DO i=1,nsplit sign(i*npmax)=' ' ENDDO * write reaction !$OMP CRITICAL (WTREAC) DO k=1,nsplit j1 = 1 + npmax*(k-1) j2 = j1 + npmax - 1 WRITE(lout,120) & rg(1),c1,rg(2),c2,rg(3),' ','=>', & (charstoi(jj),pg(jj),sign(jj),jj=j1,j2),rc1,ar2,ar3 * write keyword and label if necessary IF (idreac.gt.0) THEN IF (idreac.eq.1) THEN WRITE(lout,'(A5,I5,2x,f6.3,A1)') ' HV/',nlab,xlab,'/' ELSE IF (idreac.eq.2) THEN WRITE(lout,'(A8,I5,A1)') ' EXTRA/',nlab,'/' ELSE IF (idreac.eq.3) THEN WRITE(lout,'(A8,E9.3,F5.1,F7.0,A1)') & ' LOW /',folow(1),folow(2),folow(3),'/' WRITE(lout,'(a8,4(F6.1,1x),a1)') & ' TROE /',(fotroe(j),j=1,4),'/' ELSE WRITE(6,*) '--error--, in rxwrit3. Idreac is .gt. 2' WRITE(6,*) ' in reaction :' WRITE(6,'(a)') rg(1),c1,rg(2),c2,rg(3),' =>' STOP ENDIF ENDIF ENDDO !$OMP END CRITICAL (WTREAC) 120 FORMAT(3(A7,A1),A2,4(A5,1X,A7,1X,A1),4X,ES10.3,1X,f4.1,1X,f7.0) * write out (old fashion) : c IF (nsplit.EQ.1) a3 = '>' c DO k=1,nsplit c IF (nsplit.GT.1) WRITE(a3,'(I1)') k c j1 = 1 + 4*(k-1) c j2 = j1 + 3 c WRITE(15,121) c & a1,a2,(r(jj),jj=1,3),a3,a4, c & (charstoi(jj),p2(jj),jj=j1,j2),rc1,ar2,ar3,f298,fratio c ENDDO c c121 FORMAT(A1,A1,3(A7,1X),A1,A1, c & 3(A6,1X,A7,1X),(A7,1X,A7),ES10.3,f4.1,f7.0,ES10.3,f6.3) c RETURN END