        subroutine BIOPR
      include 'SIZE.INC'
      include 'GLOBAL.INC'
      include 'LOCAL.INC'
      include 'UNITS.INC'
      include 'LOCAL1.INC'
      include 'LOCAL2.INC'
      include 'LOCAL3.INC'
        double precision DTEMP
        real ACBACL, KBACWL, KBACSL, TEMP2, TKEL
        integer II, J, KK, III, IV, VRAIL
        integer IFORM,ION,I1,I2,I3,K,N1
        common/PRODUC/IFORM,ION,I1,I2,I3,K,N1
5000  format (' WARNING: The product chemistry specifications for'/1X,  
     &   50A1)
5010  format (' include an invalid entry at location',I5)
      if (NPROCG(N1).eq.7) go to 100
      if (NPROCG(N1).eq.8) go to 160
      go to 220
100   continue
      if (RFORMG(N1).gt.28) go to 120
      do 110 J = 1, KOUNT
         if (TYPEG(J).eq.'B') go to 110
         ACBACL = BACPLG(J,NDAT)
         KBACWL = KBACWG(IFORM,ION,I1)
         if (QTBAWG(IFORM,ION,I1).ne.0.0) KBACWL = KBACWG(IFORM,ION,I1)*
     &      QTBAWG(IFORM,ION,I1)**((TCELG(J,NDAT)-20.)/10.)
         TEMP2 = YIELDG(N1)
         if (EAYLDG(N1).ne.0.0) then
            TKEL = TCELG(J,NDAT)+273.15
            TEMP2 = 10.**(YIELDG(N1)-((1000.*EAYLDG(N1))/(4.58*TKEL)))
         endif
         DTEMP = 0.0D+00
         DTEMP = TEMP2*KBACWL*(MWTG(I2)/MWTG(I1))*ACBACL*ALPHA(I3,J,K)
         YIELDL(I2,I1,J) = YIELDL(I2,I1,J)+DTEMP
110   continue
      go to 230
120   continue
      IFORM = RFORMG(N1)-28
      do 150 J = 1, KOUNT
         II = -2
         if (TYPEG(J).eq.'B') go to 150
         ACBACL = BACPLG(J,NDAT)
         do 140 ION = 1, 7
            if (SPFLGG(ION,I1).eq.0) go to 130
            KBACWL = KBACWG(IFORM,ION,I1)
            if (QTBAWG(IFORM,ION,I1).ne.0.0) KBACWL = KBACWG(IFORM,ION,
     &         I1)*QTBAWG(IFORM,ION,I1)**((TCELG(J,NDAT)-20.)/10.)
            TEMP2 = YIELDG(N1)
            if (EAYLDG(N1).ne.0.0) then
               TKEL = TCELG(J,NDAT)+273.15
               TEMP2 = 10.**(YIELDG(N1)-((1000.*EAYLDG(N1))/(4.58*TKEL))
     &            )
            endif
            KK = 3*ION+II+IFORM-1
            DTEMP = 0.00D+00
            DTEMP = TEMP2*KBACWL*(MWTG(I2)/MWTG(I1))*ACBACL*ALPHA(KK,J,K
     &         )
            YIELDL(I2,I1,J) = YIELDL(I2,I1,J)+DTEMP
130         continue
            II = II+1
140      continue
150   continue
      go to 230
160   continue
      if (RFORMG(N1).gt.28) go to 180
      do 170 J = 1, KOUNT
         if (TYPEG(J).ne.'B') go to 170
         ACBACL = (BNBACG(J,NDAT)*SEDMSL(J))/(WATVOL(J)*100.)
         KBACSL = KBACSG(IFORM,ION,I1)
         if (QTBASG(IFORM,ION,I1).ne.0.0) KBACSL = KBACSG(IFORM,ION,I1)*
     &      QTBASG(IFORM,ION,I1)**((TCELG(J,NDAT)-20.)/10.)
         TEMP2 = YIELDG(N1)
         if (EAYLDG(N1).ne.0.0) then
            TKEL = TCELG(J,NDAT)+273.15
            TEMP2 = 10.**(YIELDG(N1)-((1000.*EAYLDG(N1))/(4.58*TKEL)))
         endif
         DTEMP = 0.00D+00
         DTEMP = TEMP2*KBACSL*(MWTG(I2)/MWTG(I1))*ACBACL*ALPHA(I3,J,K)
         YIELDL(I2,I1,J) = YIELDL(I2,I1,J)+DTEMP
170   continue
      go to 230
180   continue
      IFORM = RFORMG(N1)-28
      do 210 J = 1, KOUNT
         II = -2
         if (TYPEG(J).ne.'B') go to 210
         ACBACL = (BNBACG(J,NDAT)*SEDMSL(J))/(WATVOL(J)*100.)
         do 200 ION = 1, 7
            if (SPFLGG(ION,I1).eq.0) go to 190
            KBACSL = KBACSG(IFORM,ION,I1)
            if (QTBASG(IFORM,ION,I1).ne.0.0) KBACSL = KBACSG(IFORM,ION,
     &         I1)*QTBASG(IFORM,ION,I1)**((TCELG(J,NDAT)-20.)/10.)
            TEMP2 = YIELDG(N1)
            if (EAYLDG(N1).ne.0.0) then
               TKEL = TCELG(J,NDAT)+273.15
               TEMP2 = 10.**(YIELDG(N1)-((1000.*EAYLDG(N1))/(4.58*TKEL))
     &            )
            endif
            KK = 3*ION+II+IFORM-1
            DTEMP = 0.0D+00
            DTEMP = TEMP2*KBACSL*(MWTG(I2)/MWTG(I1))*ACBACL*ALPHA(KK,J,K
     &         )
            YIELDL(I2,I1,J) = YIELDL(I2,I1,J)+DTEMP
190         continue
            II = II+1
200      continue
210   continue
      go to 230
220   continue
      III = VRAIL(CHEMNA(1,CHPARG(N1)))
      write (TTYOUT(MACHNO),5000) (CHEMNA(IV,CHPARG(N1)),IV=1,III)
      write (TTYOUT(MACHNO),5010) N1
      write (TTYOUT(MACHNO),5020)
5020  format (1X,'This entry has caused a code malfunction in BIOPR.')
230   continue
      return
      end
