#include "dims.h"
      SUBROUTINE COMPART
      use cons_module,only: len1,len2,kmax,kmaxp1,rmassinv_o2,
     |  rmassinv_o
      implicit none
C     ****
C     ****     PARTITIONS OX INTO O AND O3
C     ****
C     ****     CALL AFTER COMP
C     ****
#include "params.h"
#include "fcom.h"
#include "vscr.h"
#include "index.h"
#include "buff.h"
#include "crates_const.h"
#include "crates_tdep.h"
#include "mwt.h"
!
! Local:
      real :: small
      integer :: nps1k,nps2k,nmsk,npohk,npho2k,nphk,npo1k,npo3k,
     |  npnok,npno2k,njo3dk,njo3pk,ntk
      integer :: i,k
      real :: temp
!
      SMALL=1.E-20
      NPS1K=NJNP+NPS      ! new O2 (input) (from comp.f)
      NPS2K=NPS1K+KMAXP1  ! new OX (input) (from comp.f)
      NMSK=NJ+NMS
      NPOHK=NJNP+NPOH     ! new OH  (input)
      NPHO2K=NJNP+NPHO2   ! new HO2 (input)
      NPHK=NJNP+NPH       ! new H   (input)
      NPO1K=NJ+NPO1       ! current O1 (new is ouput)
      NPO3K=NJ+NPO3       ! current O3 (new is ouput)
      NPNOK=NJNP+NPNO     ! new NO  (input)
      NPNO2K=NJNP+NPNO2   ! new NO2 (input)
      NJO3DK=NJO3D-1
      NJO3PK=NJO3P-1
      DO 2 K=1,KMAX
      NJO3DK=NJO3DK+1
      NJO3PK=NJO3PK+1
      NTK=NJ+NT
      DO 2 I=1,LEN1
      S13(I,K) = 0.5*(F(I,NJO3DK)+F(I,NJO3DK+1))
     1           +0.5*(F(I,NJO3PK)+F(I,NJO3PK+1))
    2 CONTINUE
C     ****
C     ****     SOURCES
C     ****
      DO 3 I=1,LEN2
C     ****     S15 = N*MBAR  (K+1/2)
      S15(I,1)=XNMBAR(I,1)
C     ****
C     ****     PARTITIONING OF OX: S7=O3/O RATIO,
C     ****      S8=O/OX RATIO
C     ****
      S7(I,1)=S15(I,1)*RKM21(I,1)*F(I,NPS1K)*rmassinv_o2*S15(I,1)/
     1    (.5*(F(I,NMSK)+F(I,NMSK+1)))
     2    /(S15(I,1)*(RKM24(I,1)*F(I,NPO1K)*rmassinv_o+
     3    (RKM7A+RKM7B)*XNO1D(I,1)/RMO1+
     3    RKM29(I,1)*F(I,NPOHK)/RMOH+RKM34(I,1)*F(I,NPHO2K)/RMHO2
     4    +RKM37(I,1)*F(I,NPHK)/RMH+BETA9(I,1)*F(I,NPNOK)/RMNO
     5   +BETA12(I,1)*F(I,NPNO2K)/RMNO2)+S13(I,1)+DEL1(I,1)*
     6   RMCL(I,1)*S15(I,1)/(.5*(F(I,NMSK)+F(I,NMSK+1))))
      S8(I,1)=1./(1.+S7(I,1))
!     S8(I,1) = merge(S8(I,1),1.E-6,S8(I,1)-1.E-6>=0.)
      if (s8(i,1) < 1.e-6) s8(i,1) = 1.e-6
!     S7(I,1) = merge(S7(I,1),(1.-S8(I,1))/S8(I,1),S7(I,1)-
!    1          (1.-S8(I,1))/S8(I,1)>=0.)
      temp = (1.-s8(i,1))/s8(i,1)
      if (s7(i,1) < temp) s7(i,1) = temp
      S10(I,1) = S8(I,1)*(RMO1+S7(I,1)*RMO3)
   3  CONTINUE
      NPS1K=NJNP+NPS     ! new O2 (input)
      NPS2K=NPS1K+KMAXP1 ! new OX (input)
      NPO1K=NJNP+NPO1    ! new O1 (output)
      NPO3K=NJNP+NPO3    ! new O3 (output)
      DO 4 I=1,LEN2
      F(I,NPO1K) = S8(I,1)*F(I,NPS2K)*RMO1/S10(I,1)
      F(I,NPO3K) = S7(I,1)*S8(I,1)*F(I,NPS2K)*RMO3/S10(I,1)
      if (f(i,npo1k) < 1.e-10) f(i,npo1k) = 1.e-10
      F(I,NPO3K) = S7(I,1)*S8(I,1)*F(I,NPS2K)*RMO3/S10(I,1)
      if (f(i,npo3k) < 1.e-10) f(i,npo3k) = 1.e-10
   4  CONTINUE
C     ****
C     ****     SET LEVEL KMAX+1 USING LOGARITHMIC INTERPOLATION
C     ****
      NPO1K = NPO1K+KMAX
      NPO3K = NPO3K+KMAX
      DO I = 1,LEN1
        F(I,NPO1K) = F(I,NPO1K-1)**2/F(I,NPO1K-2)
        F(I,NPO3K) = F(I,NPO3K-1)**2/F(I,NPO3K-2)
      ENDDO
      RETURN
      END