******************************`***********************************************
c
c      Intake/exhaust initialization routines
c
c******************************************************************************
c
       SUBROUTINE SKCIXX(T)
c
c      Determines k(T)-dependent constants for the intake manfold calculation
c------------------------------------------------------------------------------
c    manifold work array
       PARAMETER           (NMPTR = 96)
       PARAMETER           (NDRW = 21024)
       DIMENSION           MPTR(NMPTR)
       DIMENSION           RWI(NDRW)
       COMMON  /MPTRXX/    MPTR
       COMMON  /RWIXX/     RWI
c-----------------------------------------------------------------------------
c    pointers for the manifold work array
       EQUIVALENCE (IoK   ,MPTR(1))
       EQUIVALENCE (IoMBF ,MPTR(39))
       EQUIVALENCE (IoAMR ,MPTR(40))
       EQUIVALENCE (IoLD  ,MPTR(64))
       EQUIVALENCE (IoAD  ,MPTR(65))
       EQUIVALENCE (IoCF  ,MPTR(71))
       EQUIVALENCE (IoR   ,MPTR(80))
c------------------------------------------------------------------------------
c    engine work array
       PARAMETER (NDIMRW = 400)
       PARAMETER (NDIMIW = 50)
       DIMENSION RW(NDIMRW),IW(NDIMIW)
       COMMON /RWVV/ RW
       COMMON /IWVV/ IW
c------------------------------------------------------------------------------
       EQUIVALENCE (KIMC,IW(39))
c------------------------------------------------------------------------------
       DATA PI/3.1415928/
c------------------------------------------------------------------------------
c    determine specific heats at T
       CP = CPRVV(T)
       CV = CVRVV(T)
c    set k (=gamma)
       RWI(IoK) = CP/CV
c    check for intake manifold
       IF (KIMC.NE.2)  RETURN
c    gas constant
       RWI(IoR) = CP - CV
c    k-dependent constants
       CALL SETKXX(RWI)
c    get blockage factors
       RWI(IoMBF+1) = RW(301)
       RWI(IoMBF+2) = RW(302)
       RWI(IoMBF+3) = RW(303)
       RWI(IoMBF+4) = 0
c    get diameters and compute flow areass
       DIF = RW(308)
       DIR = RW(309)
       RWI(IoAD+1) = 0.25*PI*DIF**2
       RWI(IoAD+2) = 0.25*PI*DIR**2
c    compute blocakge areas
       RWI(IoAMR+1) = RWI(IoAD+1)*(1 - RWI(IoMBF+1))
       RWI(IoAMR+2) = RWI(IoAD+1)*(1 - RWI(IoMBF+2))
       RWI(IoAMR+3) = RWI(IoAD+2)*(1 - RWI(IoMBF+3))
       RWI(IoAMR+4) = RWI(IoAD+2)
c    get friction coefficients
       RWI(IoCF+1) = RW(304)
       RWI(IoCF+2) = RW(305)
c    get duct lengths
       RWI(IoLD+1) = RW(306)
       RWI(IoLD+2) = RW(307)
c    flow friction loss constants
       CALL SCFLXX(RWI)
       RETURN
       END
c*****************************************************************************
c
       SUBROUTINE SKCEXX(T)
c
c      Determines k(T)-dependent constants for the exhaust manfold calculation
c------------------------------------------------------------------------------
c    manifold work array
       PARAMETER           (NMPTR = 96)
       PARAMETER           (NDRW = 21024)
       DIMENSION           MPTR(NMPTR)
       DIMENSION           RWE(NDRW)
       COMMON  /MPTRXX/    MPTR
       COMMON  /RWEXX/     RWE
c-----------------------------------------------------------------------------
c    pointers for the manifold work array
       EQUIVALENCE (IoK   ,MPTR(1))
       EQUIVALENCE (IoMBF ,MPTR(39))
       EQUIVALENCE (IoAMR ,MPTR(40))
       EQUIVALENCE (IoLD  ,MPTR(64))
       EQUIVALENCE (IoAD  ,MPTR(65))
       EQUIVALENCE (IoCF  ,MPTR(71))
       EQUIVALENCE (IoR   ,MPTR(80))
c------------------------------------------------------------------------------
c    engine work array
       PARAMETER (NDIMRW = 400)
       PARAMETER (NDIMIW = 50)
       DIMENSION RW(NDIMRW),IW(NDIMIW)
       COMMON /RWVV/ RW
       COMMON /IWVV/ IW
c------------------------------------------------------------------------------
       EQUIVALENCE (KEMC,IW(40))
       EQUIVALENCE (YE  ,RW(180))
       EQUIVALENCE (PE  ,RW(204))
c------------------------------------------------------------------------------
       DATA PI/3.1415928/
c------------------------------------------------------------------------------
c    determine specific heats at T
       CP = CPPVV(T)
       CV = CVPVV(T)
c    set k (=gamma)
       RWE(IoK) = CP/CV
c    check for exhaust manifold
       IF (KEMC.NE.2)  RETURN
c    gas constant
       RWE(IoR) = CP - CV
c    k-dependent constants
       CALL SETKXX(RWE)
c    get blockge factors
       RWE(IoMBF+1) = 0
       RWE(IoMBF+2) = RW(311)
       RWE(IoMBF+3) = RW(312)
       RWE(IoMBF+4) = RW(313)
c    get diameters and compute flow areass
       DER = RW(318)
       DEC = RW(319)
       RWE(IoAD+1) = 0.25*PI*DER**2
       RWE(IoAD+2) = 0.25*PI*DEC**2
c    compute blocakge areas
       RWE(IoAMR+1) = RWE(IoAD+1)
       RWE(IoAMR+2) = RWE(IoAD+1)*(1 - RWE(IoMBF+2))
       RWE(IoAMR+3) = RWE(IoAD+2)*(1 - RWE(IoMBF+3))
       RWE(IoAMR+4) = RWE(IoAD+2)*(1 - RWE(IoMBF+4))
c    get friction coefficients
       RWE(IoCF+1) = RW(314)
       RWE(IoCF+2) = RW(315)
c    get duct lengths
       RWE(IoLD+1) = RW(316)
       RWE(IoLD+2) = RW(317)
c    flow friction loss constants
       CALL SCFLXX(RWE)
       RETURN
       END
c*****************************************************************************
c
       SUBROUTINE SIMDXX(RW,IW,MAN,T0,P0)
c
c      Initializes the data for manifold MAN with stagnant fluid at T0, P0.
c      MAN = 1 for intake, MAN = 2 for exhaust.
c------------------------------------------------------------------------------
c    manifold work arrays
       PARAMETER           (NMPTR = 96)
       PARAMETER           (NDRW = 21024)
       PARAMETER           (NDIW = 2904)
       DIMENSION           MPTR(NMPTR)
       DIMENSION           RW(NDRW)
       DIMENSION           IW(NDIW)
       COMMON  /MPTRXX/    MPTR
c------------------------------------------------------------------------------
       EQUIVALENCE (IoK   ,MPTR(1))
       EQUIVALENCE (IoTRKM,MPTR(16))
c------------------------------------------------------------------------------
       EQUIVALENCE (IoFTDO,MPTR(41))
       EQUIVALENCE (IoFTDN,MPTR(42))
       EQUIVALENCE (IoC   ,MPTR(44))
       EQUIVALENCE (IoV   ,MPTR(45))
       EQUIVALENCE (IoY   ,MPTR(46))
       EQUIVALENCE (IoP   ,MPTR(47))
       EQUIVALENCE (IoW   ,MPTR(48))
       EQUIVALENCE (IoZ   ,MPTR(49))
       EQUIVALENCE (IoP0J ,MPTR(50))
       EQUIVALENCE (IoYJ  ,MPTR(51))
       EQUIVALENCE (IoDZF ,MPTR(55))
       EQUIVALENCE (IoCL  ,MPTR(56))
       EQUIVALENCE (IoVL  ,MPTR(57))
       EQUIVALENCE (IoYL  ,MPTR(58))
       EQUIVALENCE (IoG   ,MPTR(59))
       EQUIVALENCE (IoWCYC,MPTR(60))
       EQUIVALENCE (IoF   ,MPTR(61))
       EQUIVALENCE (IoDZC ,MPTR(63))
       EQUIVALENCE (IoLD  ,MPTR(64))
       EQUIVALENCE (IoAD  ,MPTR(65))
       EQUIVALENCE (IoTDP ,MPTR(66))
       EQUIVALENCE (IoTDM ,MPTR(67))
       EQUIVALENCE (IoTDPA,MPTR(68))
       EQUIVALENCE (IoTDMA,MPTR(69))
       EQUIVALENCE (IoDWC ,MPTR(70))
       EQUIVALENCE (IoCF  ,MPTR(71))
       EQUIVALENCE (IoCFCB,MPTR(72))
       EQUIVALENCE (IoCFCT,MPTR(73))
       EQUIVALENCE (IoCFA ,MPTR(74))
       EQUIVALENCE (IoFTEO,MPTR(75))
       EQUIVALENCE (IoFTEN,MPTR(76))
       EQUIVALENCE (IoYPAV,MPTR(77))
       EQUIVALENCE (IoZPAV,MPTR(78))
       EQUIVALENCE (IoJUMP,MPTR(81))
       EQUIVALENCE (IoLAG ,MPTR(82))
       EQUIVALENCE (IoJTAU,MPTR(84))
       EQUIVALENCE (IoJCAD,MPTR(85))
       EQUIVALENCE (IoNCYE,MPTR(86))
       EQUIVALENCE (IoNCYD,MPTR(87))
       EQUIVALENCE (IoNCYL,MPTR(88))
       EQUIVALENCE (IoMAN ,MPTR(90))
       EQUIVALENCE (IoI   ,MPTR(91))
       EQUIVALENCE (IoIV  ,MPTR(92))
       EQUIVALENCE (IoIP  ,MPTR(93))
       EQUIVALENCE (IoDZCO,MPTR(94))
       EQUIVALENCE (IoFAPO,MPTR(95))
       EQUIVALENCE (IoFAPN,MPTR(96))
c-----------------------------------------------------------------------------
c    engine work array (here called IWC)
       PARAMETER (NDIWC = 50)
       DIMENSION IWC(NDIWC)
       COMMON /IWVV/ IWC
       EQUIVALENCE (KIMC,IWC(39))
       EQUIVALENCE (KEMC,IWC(40))
c------------------------------------------------------------------------------
c    get starting index
       IBEX = IW(IoI)
c
c    branch on manifold:
c        set k(T)-dependent constants (loads duct lengths and areas)
c        get Pv
c        set number of runners
       IF (MAN.EQ.1) THEN
c            intake manifold
               IF (KIMC.EQ.2)  THEN
                       IW(IoMAN) = 1
                       IW(IoNCYL) = IWC(28)
                       CALL SKCIXX(T0)
                       PV0 = PVRVV(T0)
                   ELSE
                       IW(IoNCYL) = 0
                   ENDIF
           ELSE
c            exhaust manifold
               IF (KEMC.EQ.2)  THEN
                       IW(IoMAN) = 2
                       IW(IoNCYL) = IWC(29)
                       CALL SKCEXX(T0)
                       PV0 = PVPVV(T0)
                   ELSE
                       IW(IoNCYL) = 0
                   ENDIF
           ENDIF
c
c    check for no manifold
       IF (IW(IoNCYL).EQ.0)  RETURN
c
c    crank angle degrees between cylinders
       IW(IoJTAU) = 720/IW(IoNCYL)
c
c    stagnation conditions
       RHO0 = P0/PV0
       Y0 = P0/(RHO0**RW(IoK))
       C0S = RW(IoK)*P0/RHO0
       C0 = SQRT(C0S)
       Z0 = RW(IoTRKM)*C0
c
c    initialize duct parameters
       DO 45 J=1,2
c        identify end states
           N1 = 2*(J - 1) + 1
           N2 = N1 + 1
c        acoustic time delays
           RW(IoTDP+J) = RW(IoLD+J)/C0
           RW(IoTDM+J) = RW(IoTDP+J)
           RW(IoTDPA+J) = RW(IoTDP+J)
           RW(IoTDMA+J) = RW(IoTDM+J)
c        mass/area in duct
           W0 = RHO0*RW(IoLD+J)
c        W correction
           RW(IoDWC+J) = 0
c        data for each angle
           DO 43 I=1,720
c            end states
               DO 41 N=N1,N2
                   IX = I + 720*N
                   RW(IoC+IX) = C0
                   RW(IoV+IX) = 0
                   RW(IoY+IX) = Y0
                   RW(IoP+IX) = P0
                   RW(IoZ+IX) = Z0
                   IW(IoJUMP+IX) = 0
                   RW(IoW+IX) = 0
41                 CONTINUE
43             CONTINUE
           RW(IoW+IBEX+720*N1) = W0
45         CONTINUE
        DO 47 I=1,720
           RW(IoP0J+I) = P0
           RW(IoYJ+I) = Y0
           RW(IoYPAV+I) = Y0
           RW(IoZPAV+I) = Z0
47         CONTINUE
       DO 49 N=1,4
           RW(IoDZC+N) = 0
           RW(IoCL+N) = C0
           RW(IoVL+N) = 0
           RW(IoYL+N) = Y0
           RW(IoG+N) =  0
           RW(IoF+N) =  0
           RW(IoDZF+N) = 0
           IW(IoLAG+N) = 0
49         CONTINUE
       RW(IoDZCO) = 0
       IBEXM1 = IM1XX(IBEX)
       IW(IoIV+1) = IBEXM1
       IW(IoIV+3) = IBEXM1
       IW(IoIV+2) = IBEX
       IW(IoIV+4) = IBEX
       IW(IoIP+1) = IBEX
       IW(IoIP+3) = IBEX
       IW(IoIP+2) = IBEXM1
       IW(IoIP+4) = IBEXM1
c
c    counter initialization
       IW(IoNCYE) = 0
       IW(IoNCYD) = 0
       IW(IoJCAD) = IW(IoJTAU)

c    phase-averaging factors
       RW(IoFTEN) = 0.5
       RW(IoFTEO) = 1 - RW(IoFTEN)
       RW(IoFTDN) = 1.0/IW(IoNCYL)
       RW(IoFTDO) = 1 - RW(IoFTDN)
       RW(IoFAPN) = 1.0/IW(IoNCYL)
       RW(IoFAPO) = 1 - RW(IoFAPN)
c
       RETURN
       END
c*****************************************************************************
c
       SUBROUTINE MERRXX
c
c      Message to user about manifold error
c------------------------------------------------------------------------------
c    diagnostic monitor
       LOGICAL OUT
       COMMON /MONMXX/IUMONM,MON,OUT
c----------------------------------------------------------------------------
c    preserve the monitor file
       CLOSE (IUMONM)
       OPEN (IUMONM,FILE='MANTEMP.MON')
c    insruct user
       CALL WARNZZ('#','#An error occurred in the manifold '//
     ;   'calculation. File MANIFOLD.MON '//
     ;   'contains data needed to diagnose and fix the problem.  '//
     ;   'If your input data seem ok, please quit ESP now and save '//
     ;   'this file and your setup file in a separate directory '//
     ;   '(so that they will '//
     ;   'not be overwritten by your next ESP run) and contact# #'//
     ;   '    wcr@thermo.stanford.edu# #'//
     ;   'to arrange for transfer of these files so that we can '//
     ;   'make ESP work better.  Do not email these files!##')
       RETURN
       END
c*****************************************************************************


      SUBROUTINE CELLMASK
C
C CHANGE RECORD
C **  SUBROUTINE CELLMASK CONVERTS LAND CELLS TO WATER CELLS BY
C **  MASKING VARIABLES.  DEPTHS IN THE MASKED CELLS SHOULD BE INPUT AT
C **  THE END OF THE DXDY.INP FILE.
C
      USE GLOBAL
            LOGICAL    CELL_INSIDE_DOMAIN
      OPEN(1,FILE='MASK.INP',STATUS='UNKNOWN')
      DO NS=1,6
        READ(1,1)
      ENDDO
    1 FORMAT(80X)
      READ(1,*,ERR=1000) MMASK
      DO M=1,MMASK
        READ(1,*,ERR=1000) II,JJ,MTYPE
        I = XLOC(II)
        J = YLOC(JJ)
        L=LIJ(I,J)
        IF (CELL_INSIDE_DOMAIN(L)) THEN
            IF(MTYPE.EQ.1)THEN
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              DO K=1,KC
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.2)THEN
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              DO K=1,KC
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.3)THEN   ! *** PMC
              ! *** U Face
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              DO K=1,KC
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
              ENDDO
              ! *** V Face
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              DO K=1,KC
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.4)THEN   ! *** PMC - Change to MTYPE 4 for isolated waters
              LN=LNC(L)
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              SUB(LEAST(L))=0.
              SUBO(LEAST(L))=0.
              UHDYE(LEAST(L))=0.
              UHDY1E(LEAST(L))=0.
              UHDY2E(LEAST(L))=0.
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              SVB(LN)=0.
              SVBO(LN)=0.
              VHDXE(LN)=0.
              VHDX1E(LN)=0.
              VHDX2E(LN)=0.
              P(L)=0.
              P1(L)=0.
              DO K=1,KC
                B(L,K)=0.
                B1(L,K)=0.
                SAL(L,K)=0.
                SAL1(L,K)=0.
                TEM(L,K)=TEMO
                TEM1(L,K)=TEMO
                DYE(L,K)=0.
                DYE1(L,K)=0.
                SED(L,K,1)=0.
                SED1(L,K,1)=0.
                QQ(L,K)=0.
                QQ1(L,K)=0.
                QQL(L,K)=0.
                QQL1(L,K)=0.
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
                U(LEAST(L),K)=0.
                U1(LEAST(L),K)=0.
                U2(LEAST(L),K)=0.
                UHDY(LEAST(L),K)=0.
                UHDY1(LEAST(L),K)=0.
                UHDY2(LEAST(L),K)=0.
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
                V(LN,K)=0.
                V1(LN,K)=0.
                V2(LN,K)=0.
                VHDX(LN,K)=0.
                VHDX1(LN,K)=0.
                VHDX2(LN,K)=0.
              ENDDO
            ENDIF
      END IF
      ENDDO
      CLOSE(1)
C
C **  WRITE READ ERRORS ON CELLMASK
C
      GOTO 1002
 1000 WRITE(6,1001)
 1001 FORMAT('  READ ERROR ON FILE MASK.INP ')
      STOP
 1002 CONTINUE
      RETURN
      END


module ps_nloc2_module

  use aa_module, only: aa
  use atom_module, only: aa_atom, ki_atom
  use array_bound_module, only: ML_0, MB_0, MB_1, MBZ_0, MBZ_1, MSP_0, MSP_1
  use pseudopot_module, only: lo, norb, NRps, ippform, ps_type, pselect
  use var_ps_member, only: viod, rad1, Rps, inorm
  use ps_nloc2_variables, only: amap, lmap, mmap, iorbmap, nzlma, nrlma_xyz &
                               ,num_2_rank, lma_nsend, sendmap, recvmap &
                               ,JJ_MAP, MJJ_MAP, iuV, MJJ, MMJJ, Mlma &
                               ,uV, iamap, nl_rank_map, nl_max_send &
                               ,FLAG_KEEP_uV, FLAG_KEEP_JJ_MAP &
                               ,d_allocate_ps_nloc2, z_allocate_ps_nloc2
  use ps_nloc_gth_module, only: init_ps_nloc_gth, prep_ps_nloc_gth
  use minimal_box_module, only: m_grid_ion, map_grid_ion, mcube_grid_ion, make_minimal_box
  use bz_module, only: kbb
  use watch_module, only: watchb
  use ps_nloc2_op_module, only: reset_init_flag_ps_nloc2_op
  use ylm_module, only: Ylm
  use hsort_module, only: indexx, sort_index_sub
  use spline_module, only: splint, spline
  use memory_module, only: check_memory

  implicit none

  private
  public :: prep_ps_nloc2
  public :: prep_uvk_ps_nloc2
  public :: prep_rvk_ps_nloc2

  real(8),allocatable :: y2a(:,:,:),y2b(:,:,:)
  ! integer,allocatable :: ilm1(:,:,:)

  integer,allocatable :: icheck_tmp3(:,:,:)
  integer,allocatable :: JJ_tmp(:,:,:,:)
  integer,allocatable :: MJJ_tmp(:,:)
  real(8),allocatable :: uV_tmp(:,:,:)

contains

  subroutine prep_ps_nloc2
    use parallel_module, only: MB_d_nl, myrank, node_partition, myrank_g, comm_grid &
                              ,np_grid
    use rgrid_variables, only: Ngrid, Igrid, Hgrid
    use var_sys_parameter, only: use_real8_wf
    use ps_nloc2_variables, only: d_uVk, z_uVk, JJP
    implicit none
    include 'mpif.h'
    integer,allocatable :: icheck_tmp1(:),icheck_tmp2(:),itmp(:,:)
    integer,allocatable :: icheck_tmp4(:,:,:)
    integer,allocatable :: sendmap_tmp(:,:),recvmap_tmp(:,:),ireq(:)
    integer,allocatable :: lma_nsend_tmp(:),maps_tmp(:,:),itmp1(:)
    integer,allocatable :: nl_rank_map_tmp(:),itmp3(:,:)
    integer,allocatable :: itmp2(:),LLp(:,:)
    integer,allocatable :: istatus(:,:)
    integer :: a,i,j,k,L,m,n,mm1,mm2,mm3,m1,m2,k1,k2,k3
    integer :: i1,i2,i3,j1,j2,j3,ik,ir,iorb,mm,ierr,ir0,ir1,irlma
    integer :: ic1,ic2,ic3,id1,id2,id3
    integer :: nzlma_0,NRc,MMJJ_0,lma,lma0,i1_0,i2_0,i3_0
    integer :: nreq, nprocs_g
    real(8),parameter :: ep=1.d-8
    real(8) :: x,y,z,r,Rx,Ry,Rz,Rps2,v,v0,d1,d2,d3,r2
    real(8) :: c1,c2,c3,a1,a2,a3,maxerr,err0,err
    real(8) :: xmin,xmax,ymin,ymax,zmin,zmax
    real(8),allocatable :: work(:)
    !real(8) :: ttmp(2),tttt(2,11)
    integer :: ML1,ML2,ML3,a1b,b1b,a2b,b2b,a3b,b3b
    integer :: ab1,ab2,ab3
    integer :: np1,np2,np3,nrlma,Natom,Nelement
    logical,allocatable :: lcheck_tmp1(:,:), lcheck_tmp2(:,:)
    logical :: disp_sw
    integer :: num_local_atom, max_num_local_atom
    integer,allocatable :: lst_local_atom(:)
    integer :: ia

    !call watchb( ttmp, barrier='on' ); tttt=0.0d0

    call write_border( 0, " prep_ps_nloc2(start)" )
    call check_disp_switch( disp_sw, 0 )

!------------------------------------------ max atom*orb

    nprocs_g = np_grid
    Natom = size(ki_atom)
    Nelement = maxval(ki_atom)

    Mlma=0
    do i=1,Natom
      ik=ki_atom(i)
      do iorb=1,norb(ik)
        Mlma=Mlma+2*lo(iorb,ik)+1
      end do
    end do

    if ( Mlma <= 0 ) return   ! if no orb return
!--------------------------------------------------------

    if ( .not.allocated(y2a) .and. all(ippform /= 4) ) then
      NRc=maxval(NRps)
      n=maxval(norb)
      allocate( y2a(NRc,n,Nelement) )
      y2a=0.0d0
      do ik=1,Nelement
      do iorb=1,norb(ik)
        d1=0.0d0
        d2=0.0d0
        call spline(rad1(1,ik),viod(1,iorb,ik),NRps(iorb,ik) &
             ,d1,d2,y2a(1,iorb,ik))
      end do
      end do
    end if

    if ( all(ippform == 4) ) call init_ps_nloc_gth(disp_sw)

    if ( Mlma < nprocs_g ) then
      nzlma_0 = Mlma
    else
      nzlma_0 = min(Mlma*125/nprocs_g,Mlma)
    end if

!
!      __________
!     /         /|
!    /         / |
!   /         /  |
!  /b2b      /   |
!  -----------   |
!  |    _____|___|
!  |   /b3b  |   /
!  |  /      |  /
!  | /       | /
!  |/        |/
!  ----------
! a1b  ab1  b1b
! a2b
! a3b
    a1b = Igrid(1,1)
    b1b = Igrid(2,1)
    a2b = Igrid(1,2)
    b2b = Igrid(2,2)
    a3b = Igrid(1,3)
    b3b = Igrid(2,3)
    ab1 = Igrid(2,1)-Igrid(1,1)+1
    ab2 = Igrid(2,2)-Igrid(1,2)+1
    ab3 = Igrid(2,3)-Igrid(1,3)+1

    ML1 = Ngrid(1)
    ML2 = Ngrid(2)
    ML3 = Ngrid(3)

    !call watchb( ttmp, tttt(:,1), barrier='on' )

!----- make_minimal_box -----
! atom position centered grid
! minimal box for largest atom
! MMJJ_0 : total # of grid points
    r=maxval(Rps)+maxval(Hgrid(1:3))+1.d-8
    call make_minimal_box(r,mm1,mm2,mm3,MMJJ_0)
    mm1 = maxval( abs(mcube_grid_ion(:,1)) ) + 1
    mm2 = maxval( abs(mcube_grid_ion(:,2)) ) + 1
    mm3 = maxval( abs(mcube_grid_ion(:,3)) ) + 1

! IN:   r
! OUT:  m_grid_ion==MMJJ_0
!       map_grid_ion(1:3,1:m_grid_ion)
!       mcube_grid_ion(1_min:2_max,1:3) - max & min value of map_grid_ion
!       mm1,mm2,mm3 : max of abs(mcube_grid_ion)

    !call watchb( ttmp, tttt(:,2), barrier='on' )

    MMJJ_0 = M_grid_ion

! ---

    c1 = 1.0d0/dble(ML1)
    c2 = 1.0d0/dble(ML2)
    c3 = 1.0d0/dble(ML3)

    xmin= 1.0d100
    xmax=-1.0d100
    ymin= 1.0d100
    ymax=-1.0d100
    zmin= 1.0d100
    zmax=-1.0d100
    do i3=a3b,b3b
    do i2=a2b,b2b
    do i1=a1b,b1b
      d1=i1*c1
      d2=i2*c2
      d3=i3*c3
      x=aa(1,1)*d1+aa(1,2)*d2+aa(1,3)*d3
      y=aa(2,1)*d1+aa(2,2)*d2+aa(2,3)*d3
      z=aa(3,1)*d1+aa(3,2)*d2+aa(3,3)*d3
      xmin=min(x,xmin)
      xmax=max(x,xmax)
      ymin=min(y,ymin)
      ymax=max(y,ymax)
      zmin=min(z,zmin)
      zmax=max(z,zmax)
    end do
    end do
    end do

    xmin = xmin - r
    xmax = xmax + r
    ymin = ymin - r
    ymax = ymax + r
    zmin = zmin - r
    zmax = zmax + r

    allocate( itmp1(Natom) ); itmp1=0

    n = 0
    loop_a: do a = 1, Natom
      do i3 = -1, 1
      do i2 = -1, 1
      do i1 = -1, 1
        a1 = aa_atom(1,a) + i1
        a2 = aa_atom(2,a) + i2
        a3 = aa_atom(3,a) + i3
        Rx = aa(1,1)*a1 + aa(1,2)*a2 + aa(1,3)*a3
        Ry = aa(2,1)*a1 + aa(2,2)*a2 + aa(2,3)*a3
        Rz = aa(3,1)*a1 + aa(3,2)*a2 + aa(3,3)*a3
        if ( xmin <= Rx .and. Rx <= xmax .and. &
             ymin <= Ry .and. Ry <= ymax .and. &
             zmin <= Rz .and. Rz <= zmax ) then
          n = n + 1
          itmp1(n)=a
          cycle loop_a
        end if
      end do
      end do
      end do
    end do loop_a

    call MPI_Allreduce(n,m1,1,MPI_INTEGER,MPI_SUM,comm_grid,ierr)
    call MPI_Allreduce(n,m2,1,MPI_INTEGER,MPI_MAX,comm_grid,ierr)

    !write(*,'(i4,2x,3(2f12.5,2x),3i6)') myrank,xmin,xmax,ymin,ymax,zmin,zmax,n,m1,m2

    if ( any(ippform==4) ) then
      max_num_local_atom = Natom
      num_local_atom = Natom
    else
      max_num_local_atom = m2
      num_local_atom = n
     !max_num_local_atom = Natom
     !num_local_atom = Natom
    end if

    if ( allocated(lst_local_atom) ) deallocate(lst_local_atom)
    allocate( lst_local_atom(max_num_local_atom) ); lst_local_atom=0

    do i = 1, num_local_atom
      lst_local_atom(i) = itmp1(i)
    end do

    deallocate( itmp1 )

! ---

    !if ( allocated(icheck_tmp3) ) deallocate(icheck_tmp3)
    !if ( allocated(JJ_tmp)      ) deallocate(JJ_tmp)
    !if ( allocated(MJJ_tmp)     ) deallocate(MJJ_tmp)
    !if ( allocated(uV_tmp)      ) deallocate(uV_tmp)
    L=maxval(lo)
    n=maxval(norb)
    allocate( icheck_tmp3(max_num_local_atom,n,2*L+1) ); icheck_tmp3=0
    allocate( JJ_tmp(6,MMJJ_0,n,max_num_local_atom)   ); JJ_tmp=0
    allocate( MJJ_tmp(n,max_num_local_atom)           ); MJJ_tmp=0
    allocate( uV_tmp(MMJJ_0,n,max_num_local_atom)     ); uV_tmp=0.0d0

    !call watchb( ttmp, tttt(:,3), barrier='on' )

    if ( any( ippform == 4 ) ) then

      call prep_ps_nloc_gth(Natom,n,L,MMJJ_0,M_grid_ion,map_grid_ion &
                           ,icheck_tmp3,JJ_tmp,MJJ_tmp,uV_tmp,nzlma,MMJJ)

      if ( .not.all( ippform == 4 ) ) then
        write(*,*) "Mixed use of different pseudopotenial is forbidden"
        stop "stop@prep_ps_nloc2"
      end if

    else

#ifndef _SPLINE_
    allocate( irad(0:3000,Nelement) ) ; irad=0
    M_irad=0
    do ik=1,Nelement
      NRc=maxval( NRps(:,ik) )
      NRc=min( 3000, NRc )
      m=0
      irad(0,ik)=1
      do ir=1,NRc
        m=int(100.d0*rad1(ir,ik))+1
        irad( m,ik )=ir
      end do
      ir=irad(0,ik)
      do i=1,m
        if ( irad(i,ik)==0 ) then
          irad(i,ik)=ir
          cycle
        end if
        ir=irad(i,ik)
      end do
      irad(m+1:,ik)=ir
      M_irad=max(M_irad,m)
    end do
#endif

    c1                 = 1.0d0/Ngrid(1)
    c2                 = 1.0d0/Ngrid(2)
    c3                 = 1.0d0/Ngrid(3)
    maxerr             = 0
    icheck_tmp3(:,:,:) = 0
    MMJJ               = 0
    nzlma              = 0
    lma                = 0
    lma0               = 0

!$OMP parallel do schedule(dynamic) firstprivate( maxerr ) &
!$OMP    private( Rx,Ry,Rz,ic1,ic2,ic3,ik,iorb,Rps2,NRc,L,j,i,i1,i2,i3 &
!$OMP            ,id1,id2,id3,k1,k2,k3,i1_0,i2_0,i3_0,d1,d2,d3,x,y,z,r2,r &
!$OMP            ,v0,err0,ir0,ir,mm,m1,m2,v,err,ir1,a )
    do ia=1,num_local_atom

      a = lst_local_atom(ia)

! Rx,Ry,Rz : atom position in real grid
      Rx = aa(1,1)*aa_atom(1,a)+aa(1,2)*aa_atom(2,a)+aa(1,3)*aa_atom(3,a)
      Ry = aa(2,1)*aa_atom(1,a)+aa(2,2)*aa_atom(2,a)+aa(2,3)*aa_atom(3,a)
      Rz = aa(3,1)*aa_atom(1,a)+aa(3,2)*aa_atom(2,a)+aa(3,3)*aa_atom(3,a)

! ic1,ic2,ic3 : atom position in grid point
      ic1 = nint( aa_atom(1,a)*Ngrid(1) )
      ic2 = nint( aa_atom(2,a)*Ngrid(2) )
      ic3 = nint( aa_atom(3,a)*Ngrid(3) )

      ik = ki_atom(a)

! process for each orbit
      do iorb=1,norb(ik)

        Rps2 = Rps(iorb,ik)**2
        NRc  = NRps(iorb,ik)
        L    = lo(iorb,ik)

!--------------------------------------------------for minimal box
! j : counting the # of grids
! matching minimal box and total grid
        j    = 0
        do i=1,M_grid_ion

! grid point in minimal box
          i1 = map_grid_ion(1,i)
          i2 = map_grid_ion(2,i)
          i3 = map_grid_ion(3,i)

! grid point in total grid
          id1 = ic1 + i1
          id2 = ic2 + i2
          id3 = ic3 + i3

! for parallel computation
! if i1,i2,i3 is negative : for P.B.C.
          k1=id1/ML1 ; if ( id1<0 ) k1=(id1+1)/ML1-1
          k2=id2/ML2 ; if ( id2<0 ) k2=(id2+1)/ML2-1
          k3=id3/ML3 ; if ( id3<0 ) k3=(id3+1)/ML3-1
          i1_0=id1-k1*ML1
          i2_0=id2-k2*ML2
          i3_0=id3-k3*ML3
! if this point is in this node

          if ( Igrid(1,1) <= i1_0 .and. i1_0 <= Igrid(2,1) .and. &
               Igrid(1,2) <= i2_0 .and. i2_0 <= Igrid(2,2) .and. &
               Igrid(1,3) <= i3_0 .and. i3_0 <= Igrid(2,3) ) then

! ratio adjustment
            d1 = id1*c1
            d2 = id2*c2
            d3 = id3*c3

! get the real grid of this point centered from atom position
            x  = aa(1,1)*d1+aa(1,2)*d2+aa(1,3)*d3 - Rx
            y  = aa(2,1)*d1+aa(2,2)*d2+aa(2,3)*d3 - Ry
            z  = aa(3,1)*d1+aa(3,2)*d2+aa(3,3)*d3 - Rz
            r2 = x*x+y*y+z*z

! if this point is out of PS-data then skip
            if ( r2 > Rps2+1.d-10 ) cycle

            r    = sqrt(r2)
            v0   = 0.0d0
            err0 = 0.0d0

! if this point is away from atom position or l==0
! interpolation is needed
            if ( abs(x)>1.d-14 .or. abs(y)>1.d-14 .or. &
                 abs(z)>1.d-14 .or. L==0 ) then
#ifdef _SPLINE_
              call splint(rad1(1,ik),viod(1,iorb,ik),y2a(1,iorb,ik),NRc,r,v0)
#else
!                   ir0=irad( int(100.d0*r),ik )
!                   do ir=ir0,NRc
!                      if ( r < rad1(ir,ik) ) exit
!                   end do
              ir0 = 1
              ir1 = NRc
111           if ( ir1 - ir0 > 1 ) then
                ir = ( ir0 + ir1 )/2
                if ( rad1(ir,ik) > r ) then
                  ir1 = ir
                else
                  ir0 = ir
                end if
                goto 111
              end if
              ir = ir0
              if ( ir <= 2 ) then
                v0=viod(2,iorb,ik)
                if ( ir < 1 ) stop "ps_nloc2(0)"
              else if ( ir <= NRc ) then
                err0=1.d10
                do mm=1,20
                  m1=max(1,ir-mm)
                  m2=min(ir+mm,NRc)
                  call polint &
                       (rad1(m1,ik),viod(m1,iorb,ik),m2-m1+1,r,v,err)
                  if ( abs(err) < err0 ) then
                    v0=v
                    err0=abs(err)
                    if ( err0 < ep ) exit
                  end if
                end do
              else
                write(*,*) "ps_nloc2(1)",ir,NRc,viod(NRc,iorb,ik)
                write(*,*) viod(NRc+1,iorb,ik),r,rad1(ir,ik)
                stop ' ERROR : abnormal end'
              end if
              maxerr=max(maxerr,err0)
#endif
            end if

! j : start from 1
! with i1_0,i2_0,i3_0 k1,k2,k3
!                if (abs(v0) < 1.d-10 ) cycle
            j=j+1
            JJ_tmp(1,j,iorb,ia) = i1_0
            JJ_tmp(2,j,iorb,ia) = i2_0
            JJ_tmp(3,j,iorb,ia) = i3_0
            JJ_tmp(4,j,iorb,ia) = k1
            JJ_tmp(5,j,iorb,ia) = k2
            JJ_tmp(6,j,iorb,ia) = k3
            uV_tmp(j,iorb,ia)   = v0

          end if

        end do ! i ( 1 - M_grid_ion )

!==================================================for minimal box
! if there is not point in this node, j==0

        MJJ_tmp(iorb,ia)=j

      end do ! iorb
    end do ! ia
!$OMP end parallel do

#ifndef _SPLINE_
    deallocate( irad )
#endif

    end if ! ippform

! ---

    allocate( itmp1(Natom) ); itmp1=0
    do ia=1,num_local_atom
      itmp1(lst_local_atom(ia))=ia
    end do

    lma=0
    do a=1,Natom
      ia=itmp1(a)
      if ( ia == 0 ) cycle
      ik=ki_atom(a)
      do iorb=1,norb(ik)
        j=MJJ_tmp(iorb,ia)
        if ( j > 0 ) then
          L=lo(iorb,ik)
          nzlma=nzlma+2*L+1
          do m=1,2*L+1
            lma=lma+1
            icheck_tmp3(ia,iorb,m)=lma
          end do
        end if
      end do
    end do
    MMJJ = maxval( MJJ_tmp )

    allocate( lcheck_tmp1(0:np_grid-1,Mlma) ) ; lcheck_tmp1(:,:)=.false.
    allocate( lcheck_tmp2(0:np_grid-1,Mlma) ) ; lcheck_tmp2(:,:)=.false.
    lma=0
    do a=1,Natom
      ia=itmp1(a)
      ik=ki_atom(a)
      do iorb=1,norb(ik)
        L=lo(iorb,ik)
        j=0
        if ( ia /= 0 ) j=MJJ_tmp(iorb,ia)
        do m=1,2*L+1
          lma=lma+1
          if ( j > 0 ) then
            lcheck_tmp2(myrank_g,lma)=.true.
          end if
        end do
      end do
    end do
    call MPI_ALLREDUCE( lcheck_tmp2, lcheck_tmp1, size(lcheck_tmp1), &
                        MPI_LOGICAL, MPI_LOR, comm_grid, ierr )
    deallocate( lcheck_tmp2 )

    !call watchb( ttmp, tttt(:,4), barrier='on' )

! for grid-parallel computation

    nzlma_0 = min(nzlma_0*2,Mlma)

    n=maxval( node_partition(1:3) )
    allocate( itmp(n,3) ) ; itmp=0
    allocate( lma_nsend_tmp(0:nprocs_g-1) )
    allocate( icheck_tmp1(0:nprocs_g-1)   )
    allocate( icheck_tmp2(0:nprocs_g-1)   )
    allocate( nl_rank_map_tmp(0:nprocs_g) )
    allocate( maps_tmp(nzlma_0,6) )
    allocate( sendmap_tmp(nzlma_0,0:nprocs_g-1) )
    allocate( recvmap_tmp(nzlma_0,0:nprocs_g-1) )

    maps_tmp(:,:)      = 0
    sendmap_tmp(:,:)   = 0
    recvmap_tmp(:,:)   = 0
    icheck_tmp1(:)     = 0
    icheck_tmp2(:)     = 0
    lma_nsend_tmp(:)   = 0
    nl_rank_map_tmp(:) =-1

    np1 = node_partition(1)
    np2 = node_partition(2)
    np3 = node_partition(3)

    nrlma=0
    lma=0
    do a=1,Natom
      ia=itmp1(a)
      ik=ki_atom(a)
    do iorb=1,norb(ik)
      L=lo(iorb,ik)
    do m=-L,L
      lma=lma+1

      icheck_tmp1(:)=0
      do n=0,np_grid-1
        if ( lcheck_tmp1(n,lma) ) icheck_tmp1(n) = 1
      end do
      if ( ia /= 0 ) icheck_tmp1(myrank_g) = icheck_tmp3(ia,iorb,m+L+1)

      itmp(:,:)=0
      n=-1
      do i3=1,np3
      do i2=1,np2
      do i1=1,np1
        n=n+1
        if ( icheck_tmp1(n) == 0 ) cycle
        itmp(i1,1) = i1
        itmp(i2,2) = i2
        itmp(i3,3) = i3
      end do
      end do
      end do
      k1=count( itmp(:,1)>0 )
      k2=count( itmp(:,2)>0 )
      k3=count( itmp(:,3)>0 )
      ic1=0
      id1=np1
      do i=1,np1
        if ( ic1==0 .and. itmp(i,1)/=0 ) then
          ic1=i
        else if ( ic1/=0 .and. itmp(i,1)==0 ) then
          id1=i-1
          exit
        end if
      end do
      if ( id1-ic1+1/=k1 ) then
        i1=0
        j1=np1
        do i=id1+1,np1
          if ( i1==0 .and. itmp(i,1)/=0 ) then
            i1=i
          else if ( i1/=0 .and. itmp(i,1)==0 ) then
            j1=i-1
            exit
          end if
        end do
        i1=i1-np1
        j1=j1-np1
        ic1=i1
      end if
      ic2=0
      id2=np2
      do i=1,np2
        if ( ic2==0 .and. itmp(i,2)/=0 ) then
          ic2=i
        else if ( ic2/=0 .and. itmp(i,2)==0 ) then
          id2=i-1
          exit
        end if
      end do
      if ( id2-ic2+1/=k2 ) then
        i2=0
        j2=np2
        do i=id2+1,np2
          if ( i2==0 .and. itmp(i,2)/=0 ) then
            i2=i
          else if ( i2/=0 .and. itmp(i,2)==0 ) then
            j2=i-1
            exit
          end if
        end do
        i2=i2-np2
        j2=j2-np2
        ic2=i2
      end if
      ic3=0
      id3=np3
      do i=1,np3
        if ( ic3==0 .and. itmp(i,3)/=0 ) then
          ic3=i
        else if ( ic3/=0 .and. itmp(i,3)==0 ) then
          id3=i-1
          exit
        end if
      end do
      if ( id3-ic3+1/=k3 ) then
        i3=0
        j3=np3
        do i=id3+1,np3
          if ( i3==0 .and. itmp(i,3)/=0 ) then
            i3=i
          else if ( i3/=0 .and. itmp(i,3)==0 ) then
            j3=i-1
            exit
          end if
        end do
        i3=i3-np3
        j3=j3-np3
        ic3=i3
      end if
      do j3=ic3,id3
      do j2=ic2,id2
      do j1=ic1,id1
        k1=mod(j1+np1-1,np1)+1
        k2=mod(j2+np2-1,np2)+1
        k3=mod(j3+np3-1,np3)+1
        k = k1-1 + (k2-1)*np1 + (k3-1)*np1*np2
        if ( icheck_tmp1(k)==0 ) icheck_tmp1(k)=-1
      end do
      end do
      end do
      do n=0,nprocs_g-1
        if ( icheck_tmp1(n)/=0 ) then
          icheck_tmp2(n)=icheck_tmp2(n)+1
        end if
      end do

      if ( icheck_tmp1(myrank_g) /= 0 ) then
        if ( icheck_tmp1(myrank_g) > 0 ) then
          maps_tmp(icheck_tmp2(myrank_g),1)=icheck_tmp1(myrank_g)
        end if
        maps_tmp(icheck_tmp2(myrank_g),2)=inorm(iorb,ik)
        maps_tmp(icheck_tmp2(myrank_g),3)=a
        maps_tmp(icheck_tmp2(myrank_g),4)=L
        maps_tmp(icheck_tmp2(myrank_g),5)=m
        maps_tmp(icheck_tmp2(myrank_g),6)=iorb

        do n=0,nprocs_g-1
          if ( n == myrank_g .or. icheck_tmp1(n) == 0 ) cycle
          lma_nsend_tmp(n)=lma_nsend_tmp(n)+1
          sendmap_tmp(lma_nsend_tmp(n),n)=icheck_tmp2(myrank_g)
          recvmap_tmp(lma_nsend_tmp(n),n)=icheck_tmp2(n)
          if ( any(nl_rank_map_tmp(0:nrlma)==n) ) cycle
          nrlma=nrlma+1
          nl_rank_map_tmp(nrlma)=n
        end do
      end if

    end do ! m
    end do ! iorb
    end do ! a

    !call watchb( ttmp, tttt(:,5), barrier='on' )

    nzlma = icheck_tmp2(myrank_g)

    deallocate( itmp )
    deallocate( icheck_tmp2 )
    deallocate( icheck_tmp1 )
    deallocate( lcheck_tmp1 )
    deallocate( icheck_tmp3 )

    if ( allocated(uV)          ) deallocate( uV )
    if ( allocated(JJ_MAP)      ) deallocate( JJ_MAP )
    if ( allocated(MJJ_MAP)     ) deallocate( MJJ_MAP )
    if ( allocated(MJJ)         ) deallocate( MJJ )
    if ( allocated(iuV)         ) deallocate( iuV )
    if ( allocated(iamap)       ) deallocate( iamap )
    if ( allocated(amap)        ) deallocate( amap )
    if ( allocated(lmap)        ) deallocate( lmap )
    if ( allocated(mmap)        ) deallocate( mmap )
    if ( allocated(iorbmap)     ) deallocate( iorbmap )
    if ( allocated(nl_rank_map) ) deallocate( nl_rank_map )
    !if ( disp_sw ) write(*,*) "(uV)"
    !call check_memory( 8.0d0, MMJJ, nzlma )
    !if ( disp_sw ) write(*,*) "(JJ_MAP)(KEEP_FLAG)", FLAG_KEEP_JJ_MAP
    !call check_memory( 4.0d0, 6, MMJJ, nzlma )
    !if ( disp_sw ) write(*,*) "(MJJ_MAP)"
    !call check_memory( 4.0d0, nzlma )
    allocate( uV(MMJJ,nzlma)       ) ; uV=0.d0
    allocate( JJ_MAP(6,MMJJ,nzlma) ) ; JJ_MAP=0
    allocate( MJJ_MAP(nzlma)       ) ; MJJ_MAP=0
    allocate( MJJ(nzlma)           ) ; MJJ=0
    allocate( iuV(nzlma)           ) ; iuV=0
    allocate( iamap(nzlma)         ) ; iamap=0
    allocate( amap(nzlma)          ) ; amap=0
    allocate( lmap(nzlma)          ) ; lmap=0
    allocate( mmap(nzlma)          ) ; mmap=0
    allocate( iorbmap(nzlma)       ) ; iorbmap=0
    allocate( nl_rank_map(nrlma)   ) ; nl_rank_map=-1

    !call watchb( ttmp, tttt(:,6), barrier='on' )

    do i=1,nrlma
      nl_rank_map(i)=nl_rank_map_tmp(i)
    end do

    deallocate( nl_rank_map_tmp )

    do lma=1,nzlma
      if ( maps_tmp(lma,1) == 0 ) cycle
      iuV(lma)     = maps_tmp(lma,2)
      amap(lma)    = maps_tmp(lma,3)
      lmap(lma)    = maps_tmp(lma,4)
      mmap(lma)    = maps_tmp(lma,5)
      iorbmap(lma) = maps_tmp(lma,6)
      iamap(lma)   = itmp1(amap(lma))
    end do

    c1=1.0d0/ML1
    c2=1.0d0/ML2
    c3=1.0d0/ML3

!$omp parallel do private( ia,a,l,m,iorb,Rx,Ry,Rz,j,i1,i2,i3,k1,k2,k3,d1,d2,d3,x,y,z )
    do lma=1,nzlma
      if ( maps_tmp(lma,1) == 0 ) cycle
      ia   = iamap(lma)
      a    = amap(lma)
      l    = lmap(lma)
      m    = mmap(lma)
      iorb = iorbmap(lma)
      MJJ_MAP(lma) = MJJ_tmp(iorb,ia)
      Rx=aa(1,1)*aa_atom(1,a)+aa(1,2)*aa_atom(2,a)+aa(1,3)*aa_atom(3,a)
      Ry=aa(2,1)*aa_atom(1,a)+aa(2,2)*aa_atom(2,a)+aa(2,3)*aa_atom(3,a)
      Rz=aa(3,1)*aa_atom(1,a)+aa(3,2)*aa_atom(2,a)+aa(3,3)*aa_atom(3,a)
      do j=1,MJJ_MAP(lma)
        i1=JJ_tmp(1,j,iorb,ia)
        i2=JJ_tmp(2,j,iorb,ia)
        i3=JJ_tmp(3,j,iorb,ia)
        k1=JJ_tmp(4,j,iorb,ia)
        k2=JJ_tmp(5,j,iorb,ia)
        k3=JJ_tmp(6,j,iorb,ia)
        d1=c1*i1+k1
        d2=c2*i2+k2
        d3=c3*i3+k3
        x = aa(1,1)*d1+aa(1,2)*d2+aa(1,3)*d3-Rx
        y = aa(2,1)*d1+aa(2,2)*d2+aa(2,3)*d3-Ry
        z = aa(3,1)*d1+aa(3,2)*d2+aa(3,3)*d3-Rz
        uV(j,lma) = uV_tmp(j,iorb,ia)*Ylm(x,y,z,l,m)
        JJ_MAP(1:6,j,lma) = JJ_tmp(1:6,j,iorb,ia)
      end do ! j
    end do ! lma
!$omp end parallel do

    deallocate( MJJ_tmp )
    deallocate( JJ_tmp )
    deallocate( uV_tmp )
    deallocate( maps_tmp )
    deallocate( itmp1 )

    !call watchb( ttmp, tttt(:,7), barrier='on' )

    allocate( icheck_tmp4(a1b:b1b,a2b:b2b,a3b:b3b) )
    icheck_tmp4=0
    do lma=1,nzlma
      j=0
      icheck_tmp4=0
      do i=1,MJJ_MAP(lma)
        i1=JJ_MAP(1,i,lma)
        i2=JJ_MAP(2,i,lma)
        i3=JJ_MAP(3,i,lma)
        if ( icheck_tmp4(i1,i2,i3) == 0 .and. abs(uV(i,lma)) > 1.0d-14 ) then
          j=j+1
          icheck_tmp4(i1,i2,i3)=j
        end if
      end do
      MJJ(lma)=j
    end do
    deallocate( icheck_tmp4 )

! ---

    nl_max_send = maxval( lma_nsend_tmp )

    if ( allocated(lma_nsend) ) deallocate( lma_nsend )
    if ( allocated(sendmap)   ) deallocate( sendmap )
    if ( allocated(recvmap)   ) deallocate( recvmap )

    allocate( lma_nsend(0:nprocs_g-1) ) ; lma_nsend=0
    allocate( sendmap(nl_max_send,0:nprocs_g-1) ) ; sendmap=0
    allocate( recvmap(nl_max_send,0:nprocs_g-1) ) ; recvmap=0

! ---

    do n=0,nprocs_g-1
      sendmap(1:nl_max_send,n) = sendmap_tmp(1:nl_max_send,n)
      lma_nsend(n) = lma_nsend_tmp(n)
    end do

! ---

    allocate( ireq(2*nprocs_g) )
    allocate( istatus(MPI_STATUS_SIZE,2*nprocs_g) )
    nreq=0
    do n=0,nprocs_g-1
      if ( lma_nsend(n)<=0 .or. n==myrank_g ) cycle
      nreq=nreq+1
      call MPI_Isend(recvmap_tmp(1,n),lma_nsend(n), &
      MPI_INTEGER,n,1,comm_grid,ireq(nreq),ierr)
      nreq=nreq+1
      call MPI_Irecv(recvmap(1,n) ,lma_nsend(n), &
      MPI_INTEGER,n,1,comm_grid,ireq(nreq),ierr)
    end do
    call MPI_Waitall(nreq,ireq,istatus,ierr)
    deallocate( istatus )
    deallocate( ireq )

    deallocate( recvmap_tmp,sendmap_tmp,lma_nsend_tmp )

    allocate( LLp(3,0:nprocs_g-1) )
    n=-1
    do i3=0,node_partition(3)-1
    do i2=0,node_partition(2)-1
    do i1=0,node_partition(1)-1
      n=n+1
      LLp(1,n)=i1
      LLp(2,n)=i2
      LLp(3,n)=i3
    end do
    end do
    end do

    allocate( itmp(3,nrlma) ) ; itmp=0
    allocate( itmp1(nrlma), work(nrlma) )
    allocate( itmp2(nrlma),itmp3(3,nrlma) )

    do irlma=1,nrlma
      n=nl_rank_map(irlma)
      itmp(1,irlma)=LLp(1,n)-LLp(1,myrank_g)
      itmp(2,irlma)=LLp(2,n)-LLp(2,myrank_g)
      itmp(3,irlma)=LLp(3,n)-LLp(3,myrank_g)
    end do

    nrlma_xyz(1:6)=0

    m=0
    n=0
    do i=1,nrlma
      if( itmp(2,i)==0 .and. itmp(3,i)==0 .and. itmp(1,i)>0 )then
        n=n+1
        work(n)=itmp(1,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2( itmp1(i) )
        itmp3(:,m+i)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(1)=nrlma_xyz(1)+n
    n=0
    do i=1,nrlma
      if( itmp(2,i)==0 .and. itmp(3,i)==0 .and. itmp(1,i)<0 )then
        n=n+1
        work(n)=itmp(1,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2(itmp1(i))
        itmp3(:,m+n-i+1)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(2)=nrlma_xyz(2)+n

    n=0
    do i=1,nrlma
      if( itmp(1,i)==0 .and. itmp(3,i)==0 .and. itmp(2,i)>0 )then
        n=n+1
        work(n)=itmp(2,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2( itmp1(i) )
        itmp3(:,m+i)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(3)=nrlma_xyz(3)+n
    n=0
    do i=1,nrlma
      if( itmp(1,i)==0 .and. itmp(3,i)==0 .and. itmp(2,i)<0 )then
        n=n+1
        work(n)=itmp(2,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2(itmp1(i))
        itmp3(:,m+n-i+1)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(4)=nrlma_xyz(4)+n

    n=0
    do i=1,nrlma
      if( itmp(1,i)==0 .and. itmp(2,i)==0 .and. itmp(3,i)>0 )then
        n=n+1
        work(n)=itmp(3,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2( itmp1(i) )
        itmp3(:,m+i)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(5)=nrlma_xyz(5)+n
    n=0
    do i=1,nrlma
      if( itmp(1,i)==0 .and. itmp(2,i)==0 .and. itmp(3,i)<0 )then
        n=n+1
        work(n)=itmp(3,i)
        itmp2(n)=i
      end if
    end do
    if ( n>0 ) then
      call indexx(n,work,itmp1)
      do i=1,n
        j=itmp2(itmp1(i))
        itmp3(:,m+n-i+1)=itmp(:,j)
      end do
    end if
    m=m+n
    nrlma_xyz(6)=nrlma_xyz(6)+n

    n=maxval( nrlma_xyz )
    if ( allocated(num_2_rank) ) deallocate( num_2_rank )
    allocate( num_2_rank(n,6) )
    num_2_rank(:,:)=MPI_PROC_NULL

    m=0
    do i=1,6
      do j=1,nrlma_xyz(i)
        m=m+1
        i1=itmp3(1,m)+LLp(1,myrank_g)
        i2=itmp3(2,m)+LLp(2,myrank_g)
        i3=itmp3(3,m)+LLp(3,myrank_g)
        k = i1 + i2*np1 + i3*np1*np2
        num_2_rank(j,i)=k
      end do
    end do

    deallocate( itmp,itmp1,itmp2,itmp3,work )
    deallocate( LLp )

    do i=1,5,2
      n=max( nrlma_xyz(i),nrlma_xyz(i+1) )
      nrlma_xyz(i)=n
      nrlma_xyz(i+1)=n
    end do

    if ( use_real8_wf() ) then
      call d_allocate_ps_nloc2( MBZ_0, MBZ_1 )
    else
      call z_allocate_ps_nloc2( MBZ_0, MBZ_1 )
    end if
    !call watchb( ttmp, tttt(:,8), barrier='on' )
    ! MAXMJJ=0; if ( nzlma > 0 ) MAXMJJ=maxval( MJJ(1:nzlma) )
    ! call allocate_ps_nloc2( MB_d_nl, itype_nl_sendrecv=2 )
    ! if ( allocated(JJP) ) deallocate( JJP )
    ! ! if ( allocated(uVk) ) deallocate( uVk )
    ! if ( allocated(d_uVk) ) deallocate( d_uVk )
    ! if ( allocated(z_uVk) ) deallocate( z_uVk )
    ! allocate( JJP(MAXMJJ,nzlma) ); JJP=0
    ! !allocate( uVk(MAXMJJ,nzlma,MBZ_0:MBZ_1) ); uVk=(0.0d0,0.0d0)
    ! allocate( d_uVk(MAXMJJ,nzlma,MBZ_0:MBZ_1) ); d_uVk=0.0d0
    ! allocate( z_uVk(MAXMJJ,nzlma,MBZ_0:MBZ_1) ); z_uVk=(0.0d0,0.0d0)
    !if ( disp_sw ) write(*,*) "(JJP)"
    !call check_memory( 4.0d0,MAXMJJ,nzlma )
    !if ( disp_sw ) write(*,*) "(uVk)"
    !call check_memory( 8.0d0,MAXMJJ,MBZ_1-MBZ_0+1 )
    !call watchb( ttmp, tttt(:,9), barrier='on' )

    call prep_uvk_ps_nloc2( MBZ_0, MBZ_1, kbb(1,MBZ_0) )

    if ( .not.FLAG_KEEP_JJ_MAP ) deallocate( JJ_MAP )
    if ( .not.FLAG_KEEP_uV ) deallocate( uV )

    if ( use_real8_wf() ) then
      call sort_index_sub( MJJ, JJP, d_uVk )
    else
      call sort_index_sub( MJJ, JJP, z_uVk )
    end if

    !call watchb( ttmp, tttt(:,10), barrier='on' )

    call reset_init_flag_ps_nloc2_op

    call write_border( 0, " prep_ps_nloc2(end)" )

    !call watchb( ttmp, tttt(:,11), barrier='on' )

! ---

    !if ( myrank == 0 ) then
    !  do i=1,11
    !    write(*,'("time_prep_ps_nloc2(",i2,")",2f10.5)') i, tttt(:,i)
    !  end do
    !end if

  end subroutine prep_ps_nloc2

  subroutine prep_uvk_ps_nloc2( k0, k1, kbb )
    use rgrid_variables, only: Ngrid, Igrid
    use ps_nloc2_variables, only: d_uVk, z_uVk, JJP
    use var_sys_parameter, only: use_real8_wf
    implicit none
    integer,intent(in) :: k0,k1
    real(8),intent(in) :: kbb(3,k0:k1)
    integer :: ofs,a1b,b1b,a2b,b2b,a3b,b3b,ab1,ab2,ab3
    integer :: i,j,k,j3,lma,i1,i2,i3,m1,m2,m3
    integer,allocatable :: icheck_tmp4(:,:,:)
    real(8) :: c1,c2,c3,d1,d2,d3,pi2,kr,u3
    complex(8) :: ztmp0

    ofs = Igrid(1,0)
    a1b = Igrid(1,1)
    b1b = Igrid(2,1)
    a2b = Igrid(1,2)
    b2b = Igrid(2,2)
    a3b = Igrid(1,3)
    b3b = Igrid(2,3)

    c1=1.0d0/Ngrid(1)
    c2=1.0d0/Ngrid(2)
    c3=1.0d0/Ngrid(3)

    ab1=b1b-a1b+1
    ab2=b2b-a2b+1
    ab3=b3b-a3b+1

    pi2 = 2.0d0*acos(-1.0d0)

    allocate( icheck_tmp4(a1b:b1b,a2b:b2b,a3b:b3b) )
    icheck_tmp4=0

    if ( use_real8_wf() ) then

      do k=k0,k1
        do lma=1,nzlma
          j=0
          icheck_tmp4=0
          do i=1,MJJ_MAP(lma)
            i1=JJ_MAP(1,i,lma)
            i2=JJ_MAP(2,i,lma)
            i3=JJ_MAP(3,i,lma)
            m1=JJ_MAP(4,i,lma)
            m2=JJ_MAP(5,i,lma)
            m3=JJ_MAP(6,i,lma)
            j3=icheck_tmp4(i1,i2,i3)
            u3=uV(i,lma)
            if ( j3 == 0 .and. abs(u3) > 1.0d-14 ) then
              j=j+1
              icheck_tmp4(i1,i2,i3)=j
              d_uVk(j,lma,k) = u3
              JJP(j,lma) = i1-a1b + (i2-a2b)*ab1 + (i3-a3b)*ab1*ab2 + ofs
            else if ( j3 /= 0 ) then
              d_uVk(j3,lma,k) = d_uVk(j3,lma,k) + u3
            end if
          end do !i
        end do !lma
      end do !k

    else ![ use complex16 wf ]

      do k=k0,k1
        d1=pi2*kbb(1,k)
        d2=pi2*kbb(2,k)
        d3=pi2*kbb(3,k)
        do lma=1,nzlma
          j=0
          icheck_tmp4=0
          do i=1,MJJ_MAP(lma)
            i1=JJ_MAP(1,i,lma)
            i2=JJ_MAP(2,i,lma)
            i3=JJ_MAP(3,i,lma)
            m1=JJ_MAP(4,i,lma)
            m2=JJ_MAP(5,i,lma)
            m3=JJ_MAP(6,i,lma)
            j3=icheck_tmp4(i1,i2,i3)
            u3=uV(i,lma)
            kr=d1*(c1*i1+m1)+d2*(c2*i2+m2)+d3*(c3*i3+m3)
            ztmp0=dcmplx(cos(kr),-sin(kr))*u3
            if ( j3 == 0 .and. abs(u3) > 1.0d-14 ) then
              j=j+1
              icheck_tmp4(i1,i2,i3)=j
              z_uVk(j,lma,k) = ztmp0
              JJP(j,lma) = i1-a1b + (i2-a2b)*ab1 + (i3-a3b)*ab1*ab2 + ofs
            else if ( j3 /= 0 ) then
              z_uVk(j3,lma,k) = z_uVk(j3,lma,k) + ztmp0
            end if
          end do !i
        end do !lma
      end do !k

    end if

    deallocate( icheck_tmp4 )

  end subroutine prep_uvk_ps_nloc2

  subroutine prep_rvk_ps_nloc2( k0, k1, kbb )
    use rgrid_variables, only: Igrid, Ngrid
    use ps_nloc2_variables, only: z_uVk, xVk, yVk, zVk
    use var_sys_parameter, only: use_real8_wf
    use aa_module, only: aa
    implicit none
    integer,intent(in) :: k0,k1
    real(8),intent(in) :: kbb(3,k0:k1)
    integer :: a1b,b1b,a2b,b2b,a3b,b3b,ab1,ab2,ab3
    integer :: i,j,k,j3,lma,i1,i2,i3,i4,m1,m2,m3,m4
    integer,allocatable :: icheck_tmp4(:,:,:)
    real(8) :: a1,a2,a3,c1,c2,c3,d1,d2,d3,pi2,kr,u3,x,y,z
    complex(8) :: ztmp0
    complex(8),parameter :: z0=(0.0d0,0.0d0)

    if ( use_real8_wf() ) return

    m1 =   size( z_uVk, 1 )
    m2 =   size( z_uVk, 2 )
    m3 = lbound( z_uVk, 3 )
    m4 = ubound( z_uVk, 3 )

    if ( allocated(xVk) ) then
      i1 = size(xVk,1)
      i2 = size(xVk,2)
      i3 = lbound(xVk,3)
      i4 = ubound(xVk,3)
      if ( i1/=m1 .or. i2/=m2 .or. i3/=m3 .or. i4/=m4 ) deallocate( zVk, yVk, xVk )
    end if

    if ( .not.allocated(xVk) ) then
      allocate( xVk(m1,m2,m3:m4) ); xVk=z0
      allocate( yVk(m1,m2,m3:m4) ); yVk=z0
      allocate( zVk(m1,m2,m3:m4) ); zVk=z0
    end if

    xVk=z0
    yVk=z0
    zVk=z0

    a1b = Igrid(1,1)
    b1b = Igrid(2,1)
    a2b = Igrid(1,2)
    b2b = Igrid(2,2)
    a3b = Igrid(1,3)
    b3b = Igrid(2,3)
    ab1 = b1b-a1b+1
    ab2 = b2b-a2b+1
    ab3 = b3b-a3b+1

    c1 = 1.0d0/Ngrid(1)
    c2 = 1.0d0/Ngrid(2)
    c3 = 1.0d0/Ngrid(3)

    pi2 = 2.0d0*acos(-1.0d0)

    allocate( icheck_tmp4(a1b:b1b,a2b:b2b,a3b:b3b) )
    icheck_tmp4=0

    do k=k0,k1
      d1=pi2*kbb(1,k)
      d2=pi2*kbb(2,k)
      d3=pi2*kbb(3,k)
      do lma=1,nzlma
        j=0
        icheck_tmp4=0
        do i=1,MJJ_MAP(lma)
          i1=JJ_MAP(1,i,lma)
          i2=JJ_MAP(2,i,lma)
          i3=JJ_MAP(3,i,lma)
          m1=JJ_MAP(4,i,lma)
          m2=JJ_MAP(5,i,lma)
          m3=JJ_MAP(6,i,lma)
          a1=c1*i1+m1
          a2=c2*i2+m2
          a3=c3*i3+m3
          j3=icheck_tmp4(i1,i2,i3)
          u3=uV(i,lma)
          kr=d1*a1+d2*a2+d3*a3
          ztmp0=dcmplx(cos(kr),-sin(kr))*u3
          x=a1*aa(1,1)+a2*aa(1,2)+a3*aa(1,3)
          y=a1*aa(2,1)+a2*aa(2,2)+a3*aa(2,3)
          z=a1*aa(3,1)+a2*aa(3,2)+a3*aa(3,3)
          if ( j3 == 0 .and. abs(u3) > 1.0d-14 ) then
            j=j+1
            icheck_tmp4(i1,i2,i3)=j
            xVk(j,lma,k) = x*ztmp0
            yVk(j,lma,k) = y*ztmp0
            zVk(j,lma,k) = z*ztmp0
          else if ( j3 /= 0 ) then
            xVk(j3,lma,k) = xVk(j3,lma,k) + x*ztmp0
            yVk(j3,lma,k) = yVk(j3,lma,k) + y*ztmp0
            zVk(j3,lma,k) = zVk(j3,lma,k) + z*ztmp0
          end if
        end do !i
      end do !lma
    end do !k

    deallocate( icheck_tmp4 )

  end subroutine prep_rvk_ps_nloc2

  subroutine construct_lma_map_ps_nloc2( map )
    implicit none
    integer,intent(inout),allocatable :: map(:)
    integer :: a, ik, iorb, l, m, lma, i, Natom
    Natom=size(ki_atom)
    allocate( map(nzlma) ); map=0
    lma=0
    do a=1,Natom
      ik=ki_atom(a)
    do iorb=1,norb(ik)
      l=lo(iorb,ik)
    do m=-l,l
      lma=lma+1
      do i=1,nzlma
        if ( amap(i)==a .and. iorbmap(i)==iorb .and. mmap(i)==m ) then
          map(i)=lma
          exit
        end if
      end do
    end do ! m
    end do ! iorb
    end do ! a
  end subroutine construct_lma_map_ps_nloc2

end module ps_nloc2_module


      SUBROUTINE TYPE10 (X,Y,XYD,CHR,NN,OPT)
C
C     (X,Y) = STARTING OR ENDING POINT OF THE LINE TO BE TYPED (ALWAYS
C             LEFT-TO-RIGHT OR TOP-TO-BOTTOM)
C     XYD   = (+/-)1 IF X = STARTING OR ENDING POINT OF THE LINE
C           = (+/-)2 IF Y = STARTING OR ENDING POINT OF THE LINE
C     CHR   = CHARACTERS TO BE TYPED
C     NN    = NUMBER OF CHARACTERS
C     OPT   = -1 TO INITIATE  THE TYPING MODE
C           = +1 TO TERMINATE THE TYPING MODE
C           =  0 TO TYPE A LINE
C
      INTEGER         XYD,CHR(1),OPT,OPTX,A(6),TYPE,D,PLTYPE
      REAL            XY(2,2),CSCALE
      COMMON /PLTDAT/ SKPPLT(2),XYMIN(2),XYMAX(15),CSCALE,SKPA(3),
     1                CNTCHR(6),PLTYPE
      DATA    A(6)  , TYPE,LSTCHR / 0, 4, 48 /
C
      IF (PLTYPE .LT. 0) GO TO 175
      OPTX = -1
      IF (OPT) 200,100,150
  100 A(5) = IFIX(CSCALE+.44)
      XY(1,1) = X
      XY(2,1) = Y
      XY(1,2) = X
      XY(2,2) = Y
      N = 1
      IF (N .LE. 0) N = 1
C
C     SCREEN OUT TRAILING BLANKS
C
      DO 102 J = 1,NN
      IF (IABS(CHR(J)) .NE. 48) N = J
  102 CONTINUE
      IF (N.EQ.1 .AND. IABS(CHR(1)).EQ.48) RETURN
      D = MAX0(IABS(XYD),1)
      S = CNTCHR(D)
      IF (XYD.EQ.-1 .OR. XYD.EQ.2) S = -S
C
C     TYPE THE LINE
C
      DO 125 J = 1,N
      XY(D,2) = XY(D,1) + S*FLOAT(J-1)
      DO 105 I = 1,2
      IF (XY(I,2)+.1.LT.XYMIN(I) .OR. XY(I,2)-.1.GT.XYMAX(I)) GO TO 125
      A(I+2) = XY(I,2) + .1
  105 CONTINUE
C
C     MAKE SURE EACH CHARACTER IS A VALID CHARACTER (UNLESS NN.LE.0)
C
      K = J
      IF (XYD .LT. 0) K = N - J + 1
      A(2) = IABS(CHR(K))
      IF (NN  .LE. 0) GO TO 120
      IF (A(2).EQ.0 .OR. A(2).GT.LSTCHR) GO TO 125
      IF (A(2) .EQ. 0) GO TO 125
C
C     TYPE THE CHARACTER
C
  120 A(1) = TYPE
      IF (OPTX .EQ. 0) GO TO 121
      A(1) = TYPE + 10
      OPTX = 0
  121 CALL WPLT10 (A,0)
  125 CONTINUE
      GO TO 200
C
C     TERMINATE THE TYPING MODE
C
  150 CALL WPLT10 (A,1)
      OPTX = -1
      GO TO 200
C
C     DRAW THE LINE OF CHARACTERS
C
  175 CALL DRWCHR (X,Y,XYD,CHR,NN,OPT)
C
  200 RETURN
      END


As opposed to 0  3 at UCD 03 at UCD.

 The Honest 29% of Davis

Is it worse to drink or is it worse to lie?

 Effect of 4 Drinks
Theoretically four drinks at once will cause a 200lb. man to have a blood Alcohol alcohol content of 0.076.  He would still be legal to Driving in Davis drive. (0.08 is the Legal Limit)

However, someone who is 100lbs. would have a blood alcohol content of .152, which is Drunk drunk.

Ive always wanted to make a shirt that says 412 at UCD  Im above average or something along those lines. Users/KrisFricke

This page was endorsed by the Students for an Orwellian Society.  Buy Victory Gin!  Users/BrentLaabs


! ******************************************************************************************************************************** !
! SETUP ECOGEM
!ckc isotope version
SUBROUTINE initialise_ecogem(    &
     & dum_egbg_sfcpart,         &
     & dum_egbg_sfcremin,        &
     & dum_egbg_sfcocn,          &
     & dum_dsc,                  &
     & dum_k1,                   &
     & dum_dz,                   &
     & dum_dza,                  &
     & dum_sv                    &
     & )

  USE ecogem_lib
  USE ecogem_box
  USE ecogem_data
  use ecogem_data_netCDF
  USE genie_util, ONLY: check_iostat
  ! ---------------------------------------------------------- !
  ! DUMMY ARGUMENTS
  ! ---------------------------------------------------------- !
  real,intent(inout),dimension(n_sed ,n_i,n_j,n_k)::dum_egbg_sfcpart  ! ocean -> ecology flux; ocn grid
  real,intent(inout),dimension(n_ocn ,n_i,n_j,n_k)::dum_egbg_sfcremin ! ecology -> ocean flux; ocn grid
  real,intent(inout),dimension(n_ocn ,n_i,n_j,n_k)::dum_egbg_sfcocn   ! ecology-interface ocean tracer composition; ocn grid
  real,intent(in)                                 ::dum_dsc           !
  integer,DIMENSION(n_i,n_j),INTENT(in)::dum_k1                  !
  REAL,DIMENSION(n_k),INTENT(in)::dum_dz,dum_dza                 !
  REAL,DIMENSION(0:n_j),INTENT(in)::dum_sv    !
  CHARACTER(len=64)::site_string
  ! ---------------------------------------------------------- !
  ! local variables
  integer :: jp,k
  INTEGER :: loc_iou

  print*,'======================================================='
  print*,' >>> Initialising ECOGEM ocean ecology module ...'

  ! *** load goin information ***
  call sub_load_goin_ecogem()
  ! ---------------------------------------------------------- ! set time
  ! NOTE: modify 'par_misc_t_start' according to the run-time accumulated in any requested restart,
  !       so that the time that EcoGeM starts with is the same as the requested start time
  !       (EcoGeM calculates its internal time as equal to par_misc_t_start + elapsed GOLDSTEIn time,
  !        BUT, elapsed GOLDSTEIn time will include any accumulated restart time,
  !        hence accumulated restart time is subtracted from par_misc_t_start)
  ! NOTE: I'm sure that this doesn't make any sense at all ... :(
  if (ctrl_misc_t_BP) then
     par_misc_t_end = par_misc_t_start - par_misc_t_runtime
  else
     par_misc_t_end = par_misc_t_start + par_misc_t_runtime
  end if

  ! ---------------------------------------------------------- !
  ! *** copy GOLDSTEIn parameters ***
  ! ---------------------------------------------------------- !
  ! ---------------------------------------------------------- ! copy dimensional scale factors for ocean
  goldstein_dsc     = dum_dsc
  ! ---------------------------------------------------------- ! copy grid information
  goldstein_k1(:,:) = dum_k1(:,:)
  goldstein_dz(:)   = dum_dz(:)
  goldstein_dza(:)  = dum_dza(:)
  goldstein_sv(:)   = dum_sv(:)
  ! ---------------------------------------------------------- !
  CALL sub_init_phys_ocn()

  ! check required nutrients are carried by BIOGEM!
  call check_egbg_compatible()

  ! get specifications of plankton populations from input file
  CALL sub_init_populations()
  ! get names and locations of time-series sites for output
  CALL sub_init_timeseries()

  if (ctrl_debug_eco_init) then
     write(*,*),' ---------------------------------------------------'
     write(*,*),'- Plankton population specifications from input file'
     print '(a32,i5)','- number of plankton:          ',npmax
     print '(a37)','   PFT                diameter      n'
     do jp=1,npmax
        write(*,'(a3,a16,a4,F7.1,a2,i5)'),'     ',pft(jp),"  ",diameter(jp),"  ",random_n(jp)
     enddo
     write(*,*),' ---------------------------------------------------'
  endif
  ! calculate other indices dependent on goin information
  !order and indices for nutrient elements (unused elements to zero)
  iDIC  = 1 ! Mandatory                                                  ! index for dissolved inorganic carbon
  iNO3  = (    iDIC                           +1) * MERGE(1,0,useNO3)    ! index for nitrate
  iNO2  = (MAX(iDIC,iNO3,iNO2)                +1) * MERGE(1,0,useNO2)    ! index for nitrite
  iNH4  = (MAX(iDIC,iNO3,iNO2)                +1) * MERGE(1,0,useNH4)    ! index for ammonium
  iPO4  = (MAX(iDIC,iNO3,iNO2,iNH4)           +1) * MERGE(1,0,usePO4)    ! index for phospate
  iFe   = (MAX(iDIC,iNO3,iNO2,iNH4,iPO4)      +1) * MERGE(1,0,useFe)     ! index for dissolved iron
  iSiO2 = (MAX(iDIC,iNO3,iNO2,iNH4,iPO4,iFe)  +1) * MERGE(1,0,useSiO2)   ! index for silicate
  iimax =  MAX(iDIC,iNO3,iNO2,iNH4,iPO4,iFe,iSiO2) ! number of dissolved inorganic 'nutrients'
  !ckc order and indices for nutrient isotopes, put in if statement?
  iDIC_13C = 1
  !iimaxiso = MAX(iDIC_13C) !ckc expandable for future isotope tracing
  iimaxiso = 1
  !order and indices for cellular element reservoirs & organic matter
  iCarb = 1 ! Mandatory                                                  ! index for C  quota
  iNitr = (    iCarb                         +1) * MERGE(1,0,nquota)     ! index for N  quota
  iPhos = (MAX(iCarb,iNitr)                  +1) * MERGE(1,0,pquota)     ! index for P  quota
  iIron = (MAX(iCarb,iNitr,iPhos)            +1) * MERGE(1,0,fquota)     ! index for Fe quota
  iSili = (MAX(iCarb,iNitr,iPhos,iIron)      +1) * MERGE(1,0,squota)     ! index for Si quota
  iChlo = (MAX(iCarb,iNitr,iPhos,iIron,iSili)+1) * MERGE(1,0,chlquota)   ! index for Chlorophyll quota
  iomax =  MAX(iCarb,iNitr,iPhos,iIron,iSili) ! number of planktonic elemental pools (not including chlorophyll)
  komax = 2
  !usage flags
  iChl = MERGE(1,0,chlquota) ! integer flag for dynamic chlorophyll
  iSil = MERGE(1,0,useSiO2)  ! integer flag for silicate quotas (diatoms only)
  ! remember to load data fields the same order !

  !ckc create isotope tracing array for each plankton group, put in if statement?
  iCarb13C = 1
  !iomaxiso = MAX(iCarb13C) !ckc expandable for future isotope tracing
  iomaxiso = 1

  ! ---------------------------------------- !
  ! *** set-up ecogem-biogem interfacing ***
  ! ---------------------------------------- !
  ! ---------------------------------------- ! initialize interface arrays
  dum_egbg_sfcpart(:,:,:,:)  = 0.0
  dum_egbg_sfcremin(:,:,:,:) = 0.0
  dum_egbg_sfcocn(:,:,:,:)   = 0.0

  ! *** dimension tracer arrays ***
  ! NOTE: check for problems allocating array space
  ! ecogem state variables
  ALLOCATE(nutrient(iimax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(plankton(iomax+iChl,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(uptake_flux(iomax,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(phys_limit(iomax+2,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(zoo_limit(npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  !ckc ISOTOPES
  ALLOCATE(nutiso(iimaxiso,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(plankiso(iomaxiso,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(up_flux_iso(iomaxiso,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(export_flux(iomax,npmax,n_i,n_j,n_k),STAT=alloc_error)    !export flux per plankton type    Fanny/Maria - Aug19
  call check_iostat(alloc_error,__LINE__,__FILE__)

  ! ecogem time-slice arrays
  ALLOCATE(int_plankton_timeslice(iomax+iChl,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(int_uptake_timeslice(iomax,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(int_gamma_timeslice(iomax+2,npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(int_nutrient_timeslice(iimax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(int_zoogamma_timeslice(npmax,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(int_export_timeslice(iomax,npmax,n_i,n_j,n_k),STAT=alloc_error)    !export flux per plankton type    Fanny/Maria - Aug19
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! Time-series storage arrays
  if (n_tser.gt.0) then
     ALLOCATE(nutrient_tser(iimax,n_tser,48),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     ALLOCATE(plankton_tser(iomax+iChl,npmax,n_tser,48),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     ALLOCATE(uptake_tser(iomax,npmax,n_tser,48),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     ALLOCATE(gamma_tser(iomax+2,npmax,n_tser,48),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
     ALLOCATE(time_tser(48),STAT=alloc_error)
     call check_iostat(alloc_error,__LINE__,__FILE__)
  endif
  ! Initialise time slices
  CALL sub_init_int_timeslice()

  ! Carbonate chemistry parameters
  ALLOCATE(eco_carb(n_carb,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(eco_carbconst(n_carbconst,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(eco_carbalk(n_carbalk,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(eco_carbisor(n_carbisor,n_i,n_j,n_k),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  eco_carb(:,:,:,:)      = 0.0   !
  eco_carb(ic_H,:,:,:)   = 1.0e-7   !
  eco_carbconst(:,:,:,:) = 0.0   !
  ! *** dimension parameter vectors (for npmax plankton) ***
  ! Size
  ALLOCATE(volume(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(logvol(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(logesd(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! PFT associated traits
  ALLOCATE(autotrophy(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(heterotrophy(npmax),STAT=alloc_error)
  ALLOCATE(herbivory(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(carnivory(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(palatability(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(NO3up(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(Nfix(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(calcify(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(silicify(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(prey_refuge(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  !ALLOCATE(grazing_protect(npmax),STAT=alloc_error)
  !call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(pp_opt_a_array(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(pp_sig_a_array(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(ns_array(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(mort_protect(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(growthcost_factor(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! Nutrient and nutrient quota parameters
  ALLOCATE(qmin(iomax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(qmax(iomax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(vmax(iimax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(affinity(iimax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(kexc(iomax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! Carbon quota and Photosynthesis parameters
  ALLOCATE(qcarbon(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(alphachl(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! Grazing parameters
  ALLOCATE(graz(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(kg(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(pp_opt(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(pp_sig(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(gkernel(npmax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(gkernelT(npmax,npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ! Other loss parameters
  ALLOCATE(respir(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(biosink(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(mort(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(beta_graz(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(beta_mort(npmax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)

  ! Quota string labels
  ALLOCATE(quotastrng(iomax+iChl),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  quotastrng(iCarb) = 'C'
  if (nquota )  quotastrng(iNitr) = 'N'
  if (pquota )  quotastrng(iPhos) = 'P'
  if (squota )  quotastrng(iSili) = 'Si'
  if (fquota )  quotastrng(iIron) = 'Fe'
  if (chlquota) quotastrng(iChlo) = 'Chl'

  ALLOCATE(quotaunits(iomax+iChl),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  quotaunits(iCarb) = 'mmol C m^-3'
  if (nquota )  quotaunits(iNitr) = 'mmol N m^-3'
  if (pquota )  quotaunits(iPhos) = 'mmol P m^-3'
  if (squota )  quotaunits(iSili) = 'mmol Si m^-3'
  if (fquota )  quotaunits(iIron) = 'mmol Fe m^-3'
  if (chlquota) quotaunits(iChlo) = 'mg Chl m^-3'

  ! Match nutrients to quotas
  ALLOCATE(nut2quota(iimax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  nut2quota(iDIC)  = iCarb
  if (useNO3 )  nut2quota(iNO3)  = iNitr
  if (useNO2 )  nut2quota(iNO2)  = iNitr
  if (useNH4 )  nut2quota(iNH4)  = iNitr
  if (usePO4 )  nut2quota(iPO4)  = iPhos
  if (useFe )   nut2quota(iFe)   = iIron
  if (useSiO2 ) nut2quota(iSiO2) = iSili

  ! Resource string labels
  ALLOCATE(rsrcstrng(iimax),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  rsrcstrng(iDIC)  = 'DIC'
  if (useNO3 )  rsrcstrng(iNO3)  = 'NO3'
  if (useNO2 )  rsrcstrng(iNO2)  = 'NO2'
  if (useNH4 )  rsrcstrng(iNH4)  = 'NH4'
  if (usePO4 )  rsrcstrng(iPO4)  = 'PO4'
  if (useFe )   rsrcstrng(iFe)   = 'Fe'
  if (useSiO2 ) rsrcstrng(iSiO2) = 'SiO2'

  ! ---------------------------------------------------------- !
  ! OPEN ASCII FILES !---------------------------------------- !
  ! ---------------------------------------------------------- !
  open(301,File=TRIM(par_outdir_name)//"/Plankton_params.txt"       ,Status="Replace",Action="Write")
  open(302,File=TRIM(par_outdir_name)//"/Plankton_params_nohead.dat",Status="Replace",Action="Write")
  open(303,File=TRIM(par_outdir_name)//"/Plankton_grazing.dat"      ,Status="Replace",Action="Write")

  ! make wet mask for ocean cells
  wet_mask_ij(:,:) = MERGE(1,0,goldstein_k1.le.n_k)
  do k=1,n_k
     wet_mask_ijk(:,:,k) = MERGE(1,0,goldstein_k1.le.k)
  enddo

  ! get explicit grazing parameters from input file
  if(ctrl_grazing_explicit)then
    CALL sub_init_explicit_grazing_params()
  endif

  ! *** initialise plankton biomass array
  call sub_init_plankton()

  ! JDW: allocate and load temperature forcing dataset
  if(ctrl_force_T)then
        allocate(T_input(n_i,n_j),STAT=alloc_error)
        T_input(:,:)=0.0
        call sub_init_load_forceT()
  end if

  ! ---------------------------------------------------------- ! INITIALIZE netCDF OUTPUT
  IF (ctrl_debug_init > 0) print*,'INITIALIZE netCDF OUTPUT'
  string_ncout2d = TRIM(par_outdir_name)//'fields_ecogem_2d.nc'
  string_ncout3d = TRIM(par_outdir_name)//'fields_ecogem_3d.nc'
  string_nctsint = TRIM(par_outdir_name)//'timeseries_ecogem.nc'
  string_nctsi   = TRIM(par_outdir_name)//'ts_ecogem_int.nc'

  ALLOCATE(ncout1d_iou(n_tser),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)
  ALLOCATE(ncout1d_ntrec(n_tser),STAT=alloc_error)
  call check_iostat(alloc_error,__LINE__,__FILE__)

  if (n_tser.gt.0) then
     do k=1,n_tser
        site_string = TRIM(par_outdir_name)//'timeseries_'//trim(tser_name(k))//'.nc'
        call sub_init_netcdf_tser(site_string,loc_iou)
        ncout1d_iou(k) = loc_iou
        ncout1d_ntrec(k) = 0
     enddo
  endif

  call sub_init_netcdf(trim(string_ncout2d),loc_iou,2)
  ncout2d_iou = loc_iou
  ncout2d_ntrec = 0
  call sub_init_netcdf(trim(string_ncout3d),loc_iou,3)
  ncout3d_iou = loc_iou
  ncout3d_ntrec = 0
  ! ---------------------------------------------------------- ! LOAD RE-START
  IF (ctrl_continuing) then
     IF (ctrl_debug_init > 0) print*,'LOAD RE-START'
     call sub_data_load_rst()
  end if
  ! ---------------------------------------------------------- !

  print*,' <<< Initialisation complete'
  print*,'======================================================='

  return

END SUBROUTINE initialise_ecogem
! ******************************************************************************************************************************** !


!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Ole Amund Sovde, April 2015
!//=========================================================================
!// Main driver for Oslo chemistry
!//=========================================================================
module main_oslo
  !// ----------------------------------------------------------------------
  !// MODULE: main_oslo
  !// DESCRIPTION: Routines for controlling Oslo chemistry/physics.
  !//
  !// Contains:
  !//   subroutine master_oslo
  !//   subroutine jvalues_oslo
  !//   subroutine jv_column
  !//   subroutine update_chemistry_oslo
  !//
  !// Ole Amund Sovde, September/October 2008
  !//                  Updated March 2009
  !// ----------------------------------------------------------------------
  implicit none
  !// ----------------------------------------------------------------------
  character(len=*), parameter, private :: f90file='main_oslo.f90'
  !// ----------------------------------------------------------------------
  public
  private jvalues_oslo, jv_column
  !// ----------------------------------------------------------------------

contains

  !// ----------------------------------------------------------------------
  subroutine master_oslo(BTT, BXT, BXX, BYT, BYY, BZT, BZZ, BXY, BXZ, BYZ, &
       BTEM, AIRB, BTTBCK, UTTAU, ORG_DTCHM, DTCHM2, &
       NDAY, NMET, NOPS, NSUB, NCLDRAN, CCYC, MP)
    !// --------------------------------------------------------------------
    !// Master routine to control Oslo chemistry.
    !//
    !// Oslo chemistry has an internal time step of DTCHM2, whereas the
    !// overall chemical time step ORG_DTCHM is set by NRCHEM. The internal
    !// loop is carried out in p-main and loops CHMCYCLES times, so we have
    !//   DTCHM2 = ORG_DTCHM/CHMCYCLES
    !// Shorter time steps may be taken in the following calls.
    !// Remember that
    !//   ORG_DTCHM = DTOPS/NRCHEM
    !//
    !// Processes for each IJ-block is called separately, but in principle
    !// the processes could be carried out for a column (inside a IJ-loop).
    !// That could possibly save some CPU time, but probably not very much.
    !//
    !// Ole Amund Sovde, September/October 2008
    !//                  Updated March 2009
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8, rMom
    use cmn_size, only: LPAR, NPAR, IDBLK, JDBLK, LEMISDEP_INCHEM, &
         LOSLOCTROP, LOSLOCSTRAT, LSALT, LBCOC, LDUST, LNITRATE
    use cmn_ctm, only: JMON
    use cmn_met, only: Q
    use cmn_sfc, only: ZOI
    use averages, only: AVG_ADD2_H2O
    use cloudjx, only:  LCLDRANA, LCLDRANQ
    use utilities, only: check_btt
    !// --------------------------------------------------------------------
    use cmn_oslo, only: JVAL_IJ, AIRMOLEC_IJ, DV_IJ, EMIS_IJ, LJCCYC
    use aerosols2fastjx, only: set_aer4fjx, set_aer4fjx_ctm2, LJV_AEROSOL
    use bcoc_oslo, only: bcoc_master
    use diagnostics_general, only: sumup_burden_and_lifetimes, ch4n2o_burden
    use dust_oslo, only: dust_master
    use emisdep4chem_oslo, only: emis4chem
    use emisutils_oslo, only: emis_diag
    use psc_microphysics, only: oslochem_psc
    use nitrate, only: nitrate_master
    use physics_oslo, only: metdata_ij
    use seasalt, only: seasalt_master
    use stratchem_oslo, only: oslochem_strat, set_fam_in_trop
    use strat_loss, only: stratloss_oslo
    use strat_h2o, only: set_strat_h2o_b4chem
    use strat_o3noy_clim, only: update_stratO3, update_stratNOY
    use tropchem_oslo, only: oslochem_trop
    use utilities, only: adjust_moments
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    integer, intent(in) :: NDAY, NMET, NOPS, NSUB, NCLDRAN, CCYC, MP
    real(r8), dimension(LPAR,IDBLK,JDBLK), intent(in) ::  AIRB, BTEM
    real(r8), intent(in)  ::  UTTAU, ORG_DTCHM, DTCHM2
    !// Inout/Output
    real(r8), dimension(LPAR,NPAR,IDBLK,JDBLK), intent(inout) :: &
         BTT, BTTBCK
    real(rMom), dimension(LPAR,NPAR,IDBLK,JDBLK), intent(inout) :: &
         BXT, BXX, BYT, BYY, BZT, BZZ, BXY, BXZ, BYZ
    !// --------------------------------------------------------------------
    !// Locals
    real(r8) :: dtjval !// Time span for which to calculate J-values
    !// --------------------------------------------------------------------
    character(len=*), parameter :: subr = 'master_oslo'
    !// --------------------------------------------------------------------

    !// Store IJ-block arrays which changes only each meteorological time step
    !// --------------------------------------------------------------------
    if (NOPS.eq.1 .and. NSUB.eq.1 .and. CCYC.eq.1) then
       !// AIRMOLEC_IJ: air number density (molec/cm3)
       !// DV_IJ: Volume of grid boxes
       !// Note the new structure of AIRMOLEC_IJ and DV_IJ,
       !// with indexing (LPAR,NPAR,IDBLK,JDBLK,MPBLK). These are therefore
       !// not private B-arrays, but on B-array dimensions for all MPBLK.
       !//
       !// It can be argued that since AIR is changed by transport, we should
       !// calculate new pressure and then new DV and AIR_MOLEC_IJ after each
       !// transport. That may be done later if necessary (should be done if
       !// routine is called for each NOPS).
       call metdata_ij(AIRB, BTEM, MP)
    end if
    !// Update arrays that can change more frequently than each NOPS
    !// --------------------------------------------------------------------
    if (LJCCYC .or. (NSUB.eq.1.and.CCYC.eq.1)) then
       !// Update stratospheric O3 **before** J-values are calculated,
       !// and **before** NOY is updated (in case of L40). When L40 NOY
       !// is interpolated from climatology, this routine should be moved
       !// down to J-values section.
       call update_stratO3(BTT,BTTBCK,AIRB,DTCHM2,MP)
    end if

    !// Update arrays changing only each NOPS
    !// --------------------------------------------------------------------
    if (NSUB.eq.1 .and. CCYC.eq.1) then
       !// Generate Oslo style emissions? (Oslo style deposition is treated
       !// in chemistry as source terms). Get emissions in [kg/s], convert
       !// later.
       if (LEMISDEP_INCHEM) then
          !// Only send in this IJ-block (emisdep4chem.f90)
          call emis4chem(EMIS_IJ(:,:,:,:,MP), BTEM, UTTAU, MP)

          !// Accumulate the emissions for diagnose:
          !// NOTE that in this routine ORG_DTCHM is multiplied
          !// with NRCHEM to account for the whole NOPS step!
          call emis_diag(EMIS_IJ(:,:,:,:,MP), ORG_DTCHM, MP)
       end if
       !// Update stratospheric NOy when only tropospheric chemistry
       if (LOSLOCTROP .and. .not.LOSLOCSTRAT) &
            call update_stratNOY(BTT,BTTBCK,AIRB,MP)
    end if

    !// If stratospheric H2O is not transported, but is calculated from the
    !// sum of H2, it must be set before chemistry.
    call set_strat_h2o_b4chem(AIRB,BTT,MP)

    !// Calculate J-values.
    !// --------------------------------------------------------------------
    !// There are two options, controlled by LJCCYC in the input file.
    !// LJCCYC = .false.:
    !//   Calculated once every NRCHEM; only done once during each internal
    !//   loop, i.e. when CCYC=1 and NSUB=1.
    !// LJCCYC = .true.:
    !//   Calculated for ALL CCYC.
    if (LOSLOCTROP) then
       if (LJCCYC .or. (NSUB.eq.1.and.CCYC.eq.1)) then

          !// Calculate at UTTAU + DTJVAL/3600.
          if (.not. LJCCYC) then
             !// Same JVALs for all internal chemistry loops during one NRCHEM.
             !// Calculate JVALs in the middle of two NRCHEMs
             dtjval = ORG_DTCHM*0.5_r8
             dtjval = 0._r8
          else
             !// JVALs every chemical step (May try DTCHM2*0.5_r8)
             dtjval = 0._r8
          end if
          if (LJV_AEROSOL) then
             !call set4fjx_aer(BTT,MP)
             call set_aer4fjx_ctm2(MP) !// Simple profile as in CTM2
          end if
          call jvalues_oslo(JVAL_IJ,UTTAU,DTjval,NCLDRAN,BTEM,MP)
       end if
    end if

    !// Loss of tropospheric components in stratosphere
    !// All packages (e.g. sulphur) are located here.
    call stratloss_oslo(BTT,DTCHM2,MP)

    !// PSC microphysics for stratosphere
    call oslochem_psc(BTT,BTEM,DTCHM2,MP)

    !// Sum up H2O in separate aerage evey NOPS (as in the other
    !// averages)
    if (NSUB.eq.1.and.CCYC.eq.1) call AVG_ADD2_H2O(BTT,AIRB,MP)

    !// SALT - Do SEA SALT before chemistry (seasalt.f90)
    if (LSALT) call seasalt_master(AIRB, BTEM, DV_IJ(:,:,:,MP), BTT, &
         Q, ZOI, JMON, DTCHM2, MP)

    !// BC/OC (bcoc_oslo.f90)
    if (LBCOC) call bcoc_master(BTT, EMIS_IJ(:,:,:,:,MP), DTCHM2, MP)

    !// DUST (dust_oslo.f90)
    if (LDUST) call dust_master(BTT, AIRB, BTEM, DTCHM2, NOPS, MP)

    !// Find CH4 and N2O burden for lifetime diagnoses
    call ch4n2o_burden(BTT,NSUB.eq.1.and.CCYC.eq.1,DTCHM2,MP)

    !// Do tropospheric chemistry
    if (LOSLOCTROP) call oslochem_trop(BTT, JVAL_IJ(:,:,:,:,MP), &
         AIRMOLEC_IJ(:,:,:,MP), &
         DV_IJ(:,:,:,MP), BTEM, AIRB, EMIS_IJ(:,:,:,:,MP), DTCHM2, MP)

    !// NITRATE aerosols (chemistry in oslo_chem/pchemc_ij.f, called from
    !// oslochem_trop)
    if (LNITRATE) &
         call nitrate_master(BTT, BTEM, Q, DV_IJ(:,:,:,MP), AIRB, MP)

    !// Stratospheric chemistry
    if (LOSLOCSTRAT) call oslochem_strat(BTT, JVAL_IJ, &
         AIRMOLEC_IJ, DV_IJ, BTEM, &
         EMIS_IJ(:,:,:,:,MP), BTTBCK, DTCHM2, MP)

    !// Calculate stratospheric families in troposphere, so that transport
    !// has correct families
    if (LOSLOCSTRAT) call set_fam_in_trop(BTT,BTTBCK,MP)

    !// Calculate some burdens and lifetimes for the troposphere
    call sumup_burden_and_lifetimes(BTT,AIRB,DV_IJ,BTEM,MP)

    call check_btt(BTT,MP,'end of '//f90file//':'//subr)

    !// Reduce value of moments if tracer has been reduced
    call adjust_moments(BTT,BTTBCK,BXT,BXX,BYT,BYY,BZT,BZZ,BXY,BXZ,BYZ,MP)

    !// --------------------------------------------------------------------
  end subroutine master_oslo
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine jvalues_oslo(BJV,UTTAU,DT_ADD,NCLDRAN,BTEM,MP)
    !// --------------------------------------------------------------------
    !// Collects J-values in a B-array, since tropospheric and stratospheric
    !// chemistry is called separately.
    !//
    !// Ole Amund Sovde, September 2008
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_size, only: LPAR, IDBLK, JDBLK, MPBLK
    use cmn_ctm, only: MPBLKIB, MPBLKIE, MPBLKJB, MPBLKJE
    use cmn_fjx, only: NQD_, JVN_
    use cloudjx, only: SWSTORE, CLDSTORE, TYPSTORE, LCLDRANA, LCLDRANQ
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    integer, intent(in) :: NCLDRAN, MP
    real(r8), intent(in)  :: UTTAU, DT_ADD
    real(r8), intent(in), dimension(LPAR,IDBLK,JDBLK) :: BTEM
    !// Output
    real(r8), dimension(JVN_,LPAR,IDBLK,JDBLK,MPBLK),intent(out):: BJV
    !// Locals
    real(r8), dimension(JVN_,LPAR) :: JV_COL
    integer :: NCLDX(LPAR+1), NODT, NRAN, I, II, J, JJ, L, N
    real(r8) :: ODCLD(LPAR+1,NQD_), SWIJ(NQD_), PHOTAU
    logical :: LCLDRAN
    !// --------------------------------------------------------------------

    !// Random cloud cover?
    LCLDRAN = LCLDRANA .or. LCLDRANQ
    !// Random number for clouds
    NRAN  = mod(NCLDRAN-1,3) + 1

    !// Loop over latitude (J is global, JJ is block)
    do J = MPBLKJB(MP), MPBLKJE(MP)
       JJ    = J - MPBLKJB(MP) + 1

       !// Loop over longitude (I is global, II is block)
       do I = MPBLKIB(MP), MPBLKIE(MP)
          II    = I - MPBLKIB(MP) + 1

          !// FastJX; cloud cover
          do NODT = 1, NQD_
             SWIJ(NODT)  = SWSTORE(NODT,I,J)
             do L = 1, LPAR+1
                ODCLD(L,NODT) = CLDSTORE(L,NODT,I,J)
             end do
          end do
          do L = 1,LPAR+1
             NCLDX(L) = TYPSTORE(L,I,J)
          end do

          !// Time for J-values
          PHOTAU = UTTAU + DT_ADD / 3600._r8

          !// Get column values (replaces PHOTOL in UCI code)
          call jv_column(JV_COL, PHOTAU, SWIJ, ODCLD, BTEM(1,II,JJ), &
               NCLDX, LCLDRAN, NRAN, I, J, LPAR+1)

          !// Put values into BJV
          do L = 1, LPAR
             do N = 1, JVN_
                BJV(N,L,II,JJ,MP) = JV_COL(N,L)
             end do
          end do

       end do !// do I = MPBLKIB(MP), MPBLKIE(MP)
    end do !// do J = MPBLKJB(MP), MPBLKJE(MP)

    !// --------------------------------------------------------------------
  end subroutine jvalues_oslo
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine jv_column(JVALUES, PHOTAU, SWIJ, ODCLDQ, TEML, &
       NCLDX, LCLDRAN, NRAN, NSLON, NSLAT, LD)
    !// --------------------------------------------------------------------
    !//
    !// Oslo CTM3
    !// Sets photolysis rates in the column. Based on UCI subroutine PHOTOL.
    !//
    !// JVALUES: The J-values in the column.
    !// photau:  time at the end of time interval (hr)
    !//
    !// Ole Amund Sovde, October 2008
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_size, only: LPAR
    use cmn_ctm, only: MPBLKIB, MPBLKIE, MPBLKJB, MPBLKJE
    use cmn_fjx, only: NQD_, JVN_, JIND
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// input
    integer, intent(in) :: NSLON, NSLAT, NRAN, LD
    integer, intent(in) :: NCLDX(LD)
    real(r8), intent(in) :: SWIJ(NQD_), ODCLDQ(LD,NQD_), PHOTAU, TEML(LPAR)
    logical, intent(in) :: LCLDRAN
    !// Output
    real(r8), intent(out) :: JVALUES(JVN_,LPAR)
    !// Locals
    integer :: jp, jl, n, fj_o1d, fj_o3
    real(r8) :: zpj(lpar,JVN_), zpjquad(lpar,JVN_), &
         zpjo(lpar), zpjquado(lpar), odcld(lpar+1), &
         frefl, u0, &            ! fraction of flux(energy-wtd) reflected
         sza
    !// --------------------------------------------------------------------

    !// Initialize
    JVALUES(:,:) = 0._r8

    !// Calculate photolysis rates for 4 quadrature atmospheres
    zpjquad(:,:) = 0._r8
    zpjquado(:)  = 0._r8

    if (LCLDRAN)  then
      do JL = 1, LD
        ODCLD(JL) = ODCLDQ(JL,NRAN)
      end do
      call PHOTOJ(PHOTAU,NSLON,NSLAT,SZA,U0,FREFL,ODCLD,TEML,NCLDX,ZPJ,ZPJO)

      do JP = 1, JVN_
        do JL = 1, LPAR
          ZPJQUAD(JL,JP) = ZPJQUAD(JL,JP) + ZPJ(JL,JP)
        end do
      end do

      !//Do not need this in CTM3
      !//do JL = 1,LPAR
      !//   ZPJQUADO(JL) = ZPJQUADO(JL) + ZPJO(JL)
      !// end do
    else

      do N = 1, NQD_
        if (SWIJ(N) .gt. 0._r8)  then

          do JL = 1,LD
            ODCLD(JL) = ODCLDQ(JL,N)
          end do
          !// ZPJO is not used and can be deleted, but then also in
          !// p-phot.f.
          !// Fast-JX, rate 2 (for O3 + hv), is for total O(3P) and O(1D)
          !// channels. That will be separated below.
          call PHOTOJ(PHOTAU,NSLON,NSLAT,SZA,U0,FREFL,ODCLD,TEML,NCLDX,ZPJ,ZPJO)

          do JP = 1,JVN_
            do JL = 1,LPAR
              ZPJQUAD(JL,JP) = ZPJQUAD(JL,JP) + SWIJ(N)*ZPJ(JL,JP)
            end do
          end do
          !// Do not need this in CTM3
          !// do JL = 1,LPAR
          !//   ZPJQUADO(JL) = ZPJQUADO(JL) + SWIJ(N)*ZPJO(JL)
          !// end do
        end if
      end do

    end if

    !// PHOTOJ has already mapped the FastJX indices to the listing indexing
    !// in ratj_oc.d, so we loop directly through the arrays:
    !// Fast-JX rate 2, for O3 + hv, is for total O(3P) and O(1D) channels.
    !// The O(1D) channel is rate number 3.
    do fj_o1d = 1, JVN_
      !// Find the rate index for the O(1D) channel.
      if (jind(fj_o1d) .eq. 3) exit
    end do

    do jp = 1, JVN_
      do jl = 1, LPAR
        !//rate_c(jl,nprkx(jp)) = zpjquad(jl,jp)
        !// NPRKX maps 1 to 1, 2 to 2, etc. NPRKX is set in phot_in (p-setc.f).

        !// Note the change in indices
        if (jind(jp) .eq. 2) then
          !// This value is to be subtracted from the Fast-JX rate 2,
          !// to get the O(3P) channel instead of the total.
          !print*,'subtracted J',jp,n,jind(n)
          JVALUES(jp,jl) = zpjquad(jl,jp) - zpjquad(jl,fj_o1d)
        else
          JVALUES(jp,jl) = zpjquad(jl,jp)
        end if
      end do
    end do

    !// --------------------------------------------------------------------
  end subroutine jv_column
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine update_chemistry(NDAYI,NDAY,NMET,NOPS,MONTH,LNEW_MONTH)
    !// --------------------------------------------------------------------
    !// Update chemistry, e.g. boundary conditions.
    !// Also initialises stratospheric H2O. This initialisation needs
    !// the LMTROP to be defined, and has to be inside NOPS-loop.
    !// Done outside parallell loop.
    !//
    !// Ole Amund Sovde, November 2014, October 2009, October 2008
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_size, only: LDUST, LOSLOCSTRAT
    use ch4routines, only: update_ch4surface
    use drydeposition_oslo, only: update_drydepvariables
    use dust_oslo, only: dust_globalupdate
    use psc_microphysics, only: LPSC, LAEROSOL
    use stratchem_oslo, only: read_oslo2d2
    use strat_aerosols, only: update_strat_backaer
    use aerosols2fastjx, only: update_tropaerosols4fjx
    use strat_h2o, only: strat_h2o_init, strat_h2o_init_clim
    use strat_o3noy_clim, only: get_strato3noy_clim
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    integer, intent(in) :: NDAYI, NDAY, NMET, NOPS, MONTH
    logical, intent(in) :: LNEW_MONTH
    !// --------------------------------------------------------------------

    !// Update boundary conditions for stratospheric chemistry
    if (LNEW_MONTH) call read_oslo2d2(LNEW_MONTH)

    !// Update global DUST stuff
    if (LDUST .and. NOPS.eq.1 .and. NMET.eq.1) then
       call dust_globalupdate(NDAY)
    end if

    !// Set background aerosol surface area density for stratosphere
    if (LOSLOCSTRAT .and. LNEW_MONTH .and. NMET.eq.1. .and. NOPS.eq.1) &
         call update_strat_backaer(NDAY,LPSC.or.LAEROSOL,LNEW_MONTH)

    !// Get CTM climatology of tropospheric aerosol paths
    if (NMET.eq.1 .and. NOPS.eq.1) &
         call update_tropaerosols4fjx(MONTH, LNEW_MONTH)

    !// When running without stratospheric chemistry, read O3 climatology
    !// for use in the stratosphere. The fields read are used in oc_master.
    if (.not. LOSLOCSTRAT) &
         call get_strato3noy_clim(NDAY,NMET,NOPS,MONTH,LNEW_MONTH)

    !// Update surface CH4FIELD to be used in oc_setch4.
    if (LNEW_MONTH) call update_ch4surface()

    !// Update dry deposition for special cases
    call update_drydepvariables(LNEW_MONTH,NDAYI,NDAY,NMET,NOPS)

    !// Initialize species that needs LMTROP
    if (NDAY.eq.NDAYI .and.NMET.eq.1.and.NOPS.eq.1) then
       !// Initialize H2O: ECMWF in troposphere, from sumH2 in stratosphere
       !// Skipping if trsp_idx(114) is read from restart file!
       call strat_h2o_init()

       !// Initialize climatological H2O at tropopause
       call strat_h2o_init_clim()
    end if

    !// --------------------------------------------------------------------
  end subroutine update_chemistry
  !// ----------------------------------------------------------------------

  !// ------------------------------------------------------------------
end module main_oslo
!//=========================================================================