SUBROUTINE CMPN2D
      implicit none
C     ****
C     ****     CALCULATES PSI(N2D) ASSUMING PHOTOCHEMICAL EQUILIBRIUM
C     ****     NOTE: THIS IS DIAGNOSTIC.  CALL BEFORE CMPN4S AND CMPNO
C     ****
      include "params.h"
      include "blnk.h"
      include "vscr.h"
      include "cons.h"
      include "index.h"
      include "buff.h"
      include "crates.h"
      real :: rmn4s,rmn2d,rmno,brn2d,cee
      COMMON/MASS/ RMN4S,RMN2D,RMNO,BRN2D,CEE
!
! Local:
      integer :: npnok,npn4sk,npn2dk,ntk,nps1k,nps2k,nno2k,nek,
     |  nqtefk,nopk,nn2pk,nnopk,k,i
!
      NPNOK=NJ+NPNO
      NPN4SK=NJ+NPN4S
      NPN2DK=NPN2D+NJNP
      NTK=NJ+NT
      NPS1K=NJ+NPS
      NPS2K=NPS1K+KMAXP1
      NNO2K=NNO2
      NEK=NJ+NE
      NQTEFK=NQTEF-1
      NOPK=NJ+NOP
      NN2PK=NN2P
      NNOPK=NNOP
      DO 1 K=1,KMAX
      NQTEFK=NQTEFK+1
      DO 1 I=1,LEN1
C     ****     S1 = EXPS(K+1/2),    S2 = PN2D(K+1/2)
      S1(I,K)=EXPS(K)
      S2(I,K)=.5*(F(I,NQTEFK)+F(I,NQTEFK+1))*BRN2D
    1 CONTINUE
      DO 3 I=1,LEN2
C     ****     S1 = N*MBAR  (K+1/2)
      S1(I,1)=S1(I,1)*C(81)/(C(84)*F(I,NTK)*(F(I,NPS1K)/RMASS(1)+
     1F(I,NPS2K)/RMASS(2)+(1.-F(I,NPS1K)-F(I,NPS2K))/RMASS(3)))
C     ****     S2 = TOTAL N2D PRODUCTION
      S2(I,1)=S2(I,1)+RK3(I,1)*F(I,NN2PK)*S1(I,1)*F(I,NPS2K)/RMASS(2)+
     1(RA1(I,1)*F(I,NNOPK)*0.85+RA3(I,1)*F(I,NN2PK)*0.9)*SQRT(F(I,NEK)
     2*F(I,NEK+1))
C     ****     S3 = (TOTAL N2D LOSS)/N(N2D)
      S3(I,1)=S1(I,1)*(BETA2(I,1)*F(I,NPS1K)/RMASS(1)+BETA4(I,1)*
     1F(I,NPS2K)/RMASS(2)+BETA6(I,1)*F(I,NPNOK)/RMNO)+BETA7(I,1)+
     2BETA5(I,1)*SQRT(F(I,NEK)*F(I,NEK+1))+RK10(I,1)*F(I,NOPK)
C     ****     S1 = PSI(N2D)
      S1(I,1)=RMN2D*S2(I,1)/(S3(I,1)*S1(I,1))
    3 CONTINUE
      DO 4 I=1,LEN2
C     ****     F(NPN2DK) = PSI(N2D)
      F(I,NPN2DK)=S1(I,1)
    4 CONTINUE
      RETURN
      END
C