c ***************************************************************
c *                                                             *
c * domain_compute - drive execution of element routines to     *
c *                  compute j and i-integrals for a single     *
c *                  domain                                     *
c *                                                             *
c *                  -> drive MPI to process all elements       *
c *                                                             *
c *                  last update:  5/31/2018 rhd                *
c *                                                             *
c ***************************************************************
c
c
      subroutine dicmj
c
      use global_data, only : myid, iout=>out, nelblk, elblks,
     a                        worker_processor, numprocs, num_threads
c
      use j_data, only : debug_driver, ring_count, symmetric_domain,
     a  print_elem_values, q_element_maps, q_values,
     b  front_element_list, comput_i, e_front, nu_front, comput_j,
     d  cf_traction_flags, expanded_front_nodes, front_q_area,
     e  face_loading, static_j,
     f  domain_min_j, domain_max_j,
     g  domain_min_i, domain_max_i, domain_avg_i, static_min,
     h  static_max, static_avg, ks_from_j, nowring, domain_avg_j,
     i  e33_front, domain_id, j_from_ks, print_totals, j_storage,
     j  i_storage, size_j_values, size_i_values,
     k  j_geonl_formulation, j_linear_formulation,
     l  temperatures_on_model
c
      implicit none
c
c          local declarations.
c
      integer :: now_thread
      integer, external ::  omp_get_thread_num
c
      double precision ::
     &   jtotal, symm_factor, di_value_j, static_di,
     &   static_total, Ki, T11, T33, T13, sign
c
      double precision :: diterms(size_i_values), itotal(size_i_values),
     &   iiterms(size_i_values,size_i_values),
     &   di_value_i(size_j_values)
c
      double precision, allocatable :: diterms_thrds(:,:),
     &                                 iiterms_thrds(:,:,:)
c
      integer :: i, j, skipped_killed, ierr, blk
      integer, save :: message_count=0, message_count2=0
      logical ::  chk_killed
      double precision, parameter :: zero=0.0d0, one=1.0d0,
     &                               two=2.0d0, toler_static_j=1.0d-5
c
c          if running parallel MPI:
c             alert all workers to enter this routine, then send all
c             data required for J-I calculations that is only on root.
c
      call wmpi_alert_slaves( 27 )
      call wmpi_send_jint
c
      if( debug_driver ) write(iout,*) ' >>> entered element driver'
c
c          keep track of ring_count for storing and retrieving output
c
      ring_count = ring_count + 1
c
c          initialize totals for domain and set symmetry factor.
c          print necessary column headers. use arrays to reduce
c          per thread contibutions for J and II terms. saves
c          lots of atomic updates inside block driver
c          routine.
c
      diterms          = zero ! all
      iiterms          = zero !  "
      skipped_killed   = 0
      message_count    = 0
      message_count2   = 0
      symm_factor      = one
      if( symmetric_domain ) symm_factor = two
      if( myid .eq. 0 ) then
         if( print_elem_values ) write(iout,9100)
         if( print_elem_values ) write(iout,9110)
      end if
c
      allocate( diterms_thrds(size_j_values,num_threads),
     &   iiterms_thrds(size_i_values,size_i_values,num_threads) )
      diterms_thrds = zero
      iiterms_thrds = zero
c
c          loop over all element blocks. inside block checks
c          if element is in current domain
c
c$OMP PARALLEL DO PRIVATE( now_thread, blk ) ! all else shared
      do blk = 1, nelblk
         if( elblks(2,blk) .ne. myid ) cycle
         now_thread = omp_get_thread_num() + 1
         call dicmj_do_a_blk( blk, now_thread,
     &      diterms_thrds(1,now_thread), iiterms_thrds(1,1,now_thread),
     &      message_count, message_count2  )
      end do
c$OMP END PARALLEL DO
c
c          reduce all thread contributions to J and II terms
c
      do i = 1, num_threads
        diterms = diterms + diterms_thrds(:,i)
        iiterms = iiterms + iiterms_thrds(:,:,i)
      end do
c
      call wmpi_reduce_vec( diterms, size_j_values )
      call wmpi_reduce_vec( iiterms(1,1), size_i_values**2 )
      call wmpi_redint( skipped_killed )
      call wmpi_redlog( face_loading )
c
      if( worker_processor ) then
        if( allocated( q_values ) ) deallocate( q_values )
        if( allocated( q_element_maps ) ) deallocate( q_element_maps )
        if( allocated( front_element_list ) )
     &      deallocate( front_element_list )
        if( allocated( expanded_front_nodes ) )
     &      deallocate( expanded_front_nodes )
        return
      end if
c
c             done with this domain computation. print values
c             as required based on user specified flags.
c
c             only rank 0 runs this code. see deallocate/return
c             above for workers
c
c             J-integral results:
c
      if( comput_j ) call dicmj_finalize_j_terms
c
c             interaction-integral results:
c             calculate K from relationship with interaction integral
c
c             the 8 terms for I-integral results are stored
c             in array e_iresults(8,7) as follows:
c
c                               value    auxiliary field
c
c                  iiterms(i,1): KI       plane stress
c                  iiterms(i,2): KI       plane stress
c                  iiterms(i,3): KII      plane stress
c                  iiterms(i,4): KII      plane stress
c                  iiterms(i,5): KIII     anti-plane shear
c                  iiterms(i,6): T11,T33  plane stress
c                  iiterms(i,7): T11,T33  plane strain
c                  iiterms(i,8): T13      anti-plane strain
c
      if( comput_i ) call dicmj_finalize_i_terms
c
c             compute J-values from K-values...
c
c             including KI plane stress, KII plane stress, and KIII
c
      j_from_ks(ring_count,1) = i_storage(ring_count,11,1)**2 / e_front
     &                        + i_storage(ring_count,11,3)**2 / e_front
     &                        + i_storage(ring_count,11,5)**2
     &                        * (one + nu_front ) / e_front
c
c             including KI plane strain, KII plane strain, and KIII
c
      j_from_ks(ring_count,2) = i_storage(ring_count,11,2)**2
     &                          * (one - nu_front**2 ) / e_front
     &                        + i_storage(ring_count,11,4)**2
     &                          * (one - nu_front**2 ) / e_front
     &                        + i_storage(ring_count,11,5)**2
     &                        * (one + nu_front ) / e_front
c
c             print sum of values from all elements in domain
c
      call dicmj_print_values
c
      return
c
 9100 format(/,1x,25x,'domain integral components',
     &  /,      1x,25x,'--------------------------')
 9110 format(7x,'element',5x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8' )
c
      contains
c     ========
c
c***************************************************************
c                                                              *
c      dicmj -> contains dicmj_finalize_j_terms                *
c                                                              *
c        written by: rhd                                       *
c        last modified: 3/30/2018 rhd                          *
c                                                              *
c***************************************************************
c
      subroutine dicmj_finalize_j_terms
      implicit none
c
      jtotal = diterms(1) + diterms(2) + diterms(3) + diterms(4) +
     &         diterms(5) + diterms(6) + diterms(7) + diterms(8)
      if( abs(diterms(3)+diterms(4)).lt.toler_static_j*abs(jtotal) )
     &     static_j = .true.
      static_total = diterms(1) + diterms(2) + diterms(5)
     &             + diterms(6) + diterms(7) + diterms(8)
      di_value_j   = jtotal / front_q_area
      static_di    = static_total / front_q_area
      domain_min_j = min( domain_min_j, di_value_j )
      domain_max_j = max( domain_max_j, di_value_j )
      domain_avg_j = domain_avg_j + di_value_j
      static_min   = min( static_min, static_di  )
      static_max   = max( static_max, static_di  )
      static_avg   = static_avg + static_di
c
c             calculate stress intensity factor K, from J, for:
c
c               1. plane stress where loading is pure mode I or mode II.
c               2. plane strain where loading is pure mode I or mode II.
c               3. anti-plane shear where loading is pure mode III.
c
c             if J is negative, calculate K from |J|, and then change sign.
c
      sign = di_value_j / abs(di_value_j)
c
      ks_from_j(ring_count,1) = sqrt(abs(di_value_j) * e_front)*sign
c
      ks_from_j(ring_count,2) =
     &     sqrt(abs(di_value_j) * e_front/(one - nu_front**2))*sign
c
      ks_from_j(ring_count,3) =
     &     sqrt(abs(di_value_j) * e_front/(one + nu_front)) * sign
c
c          store J-integral values for output in didriv.f
c
      j_storage(ring_count,1)   = dble( nowring )
      j_storage(ring_count,2:9) = diterms(1:8)
      j_storage(ring_count,10)  = di_value_j
      j_storage(ring_count,11)  = dble(skipped_killed)
c
      return
      end subroutine dicmj_finalize_j_terms
c
c***************************************************************
c                                                              *
c      dicmj -> contains dicmj_finalize_i_terms                *
c                                                              *
c        written by: rhd                                       *
c        last modified: 3/30/2018 rhd                          *
c                                                              *
c***************************************************************
c
      subroutine dicmj_finalize_i_terms
      implicit none
c
      do j = 1, 8
         itotal(j) = iiterms(1,j) + iiterms(2,j) + iiterms(3,j)
     &             + iiterms(4,j) + iiterms(5,j) + iiterms(6,j)
     &             + iiterms(7,j) + iiterms(8,j)
         di_value_i(j) = itotal(j) / front_q_area
c
c          calculate stress intensity factors and T-stress
c
         Ki  = zero
         T11 = zero
         T33 = zero
         T13 = zero
c
c          KI (plane stress auxiliary fields)
c
         if( j .eq. 1 ) Ki = di_value_i(j) * e_front / two
c
c          KI (plane strain auxiliary fields)
c
         if( j .eq. 2 ) Ki = di_value_i(j) * e_front
     &                     / ( two * (one - nu_front**2) )
c
c          KII (plane stress auxiliary fields)
c
         if( j .eq. 3 ) Ki = di_value_i(j) * e_front / two
c
c          KII (plane strain auxiliary fields)
c
         if( j .eq. 4 ) Ki = di_value_i(j) * e_front
     &                     / ( two * (one - nu_front**2) )
c
c          KIII (anti-plane shear auxiliary fields)
c
         if( j .eq. 5 ) Ki = di_value_i(j) * e_front
     &                     / (two * (one + nu_front))
c
c          T11, T33 (plane stress auxiliary fields)
c
         if( j .eq. 6 ) then
            T11 = e_front * di_value_i(j)
            Ki  = T11
            T33 = zero
            domain_min_i(9) = T33
            domain_max_i(9) = T33
            domain_avg_i(9) = T33
         end if
c
c          T11, T33 (plane strain auxiliary fields)
c
         if( j .eq. 7 ) then
           T11 = e_front / (one - nu_front**2 )
     &         * ( di_value_i(j) + nu_front * e33_front )
           T33 = e33_front * e_front + nu_front * T11
           Ki  = T11
           domain_min_i(10) = min( domain_min_i(10), T33 )
           domain_max_i(10) = max( domain_max_i(10), T33 )
           domain_avg_i(10) = domain_avg_i(10) + T33
         end if
c
c             T13 (anti-plane shear auxiliary fields)
c
         if( j .eq. 8 ) then
            T13 = di_value_i(j) * e_front / (two * (one + nu_front ))
            Ki  = T13
         end if
c
c             determine maximum and minimum values
c
         domain_min_i(j) = min( domain_min_i(j), Ki )
         domain_max_i(j) = max( domain_max_i(j), Ki )
         domain_avg_i(j) = domain_avg_i(j) + Ki
c
c             store i-integral values for output in didriv.f
c
         i_storage(ring_count,1,j)   = dble( nowring )
         i_storage(ring_count,2:9,j) = iiterms(1:8,j)
         i_storage(ring_count,10,j)  = di_value_i(j)
         i_storage(ring_count,11,j)  = Ki
         if( j.eq.7 ) i_storage(ring_count,12,j) = T33
         i_storage(ring_count,13,j)  = dble(skipped_killed)
      end do  !  on i
c
      return
      end subroutine dicmj_finalize_i_terms
c***************************************************************
c                                                              *
c      dicmj -> contains dicmj_print_values                    *
c                                                              *
c        written by: rhd                                       *
c        last modified: 3/30/2018 rhd                          *
c                                                              *
c***************************************************************
c
      subroutine dicmj_print_values
      implicit none

      if ( print_elem_values ) then
         write(iout,9160)
         if( comput_j ) write(iout,9170) "J     ", (diterms(i),i=1,8),
     &        jtotal
         if( comput_i ) then
            write(iout,9170) "I_KI  ", (iiterms(i,1),i=1,8), itotal(1)
            write(iout,9170) "I_KI  ", (iiterms(i,2),i=1,8), itotal(2)
            write(iout,9170) "I_KII ", (iiterms(i,3),i=1,8), itotal(3)
            write(iout,9170) "I_KII ", (iiterms(i,4),i=1,8), itotal(4)
            write(iout,9170) "I_KIII", (iiterms(i,5),i=1,8), itotal(5)
            write(iout,9170) "I_T11 ", (iiterms(i,6),i=1,8), itotal(6)
            write(iout,9170) "I_T11 ", (iiterms(i,7),i=1,8), itotal(7)
            write(iout,9170) "I_T13 ", (iiterms(i,8),i=1,8), itotal(8)
         end if
      end if
c
c             print sum of values from all elements in domain,
c             and J, I for domain
c
      if( print_totals ) then   ! should not be used now (3/9/2018, rhd)
         write(iout,9180)
         if( nowring .eq. 0 ) then
            if( comput_j .and. comput_i ) write(iout,9185)
            if( comput_j .and. .not. comput_i ) write(iout,9186)
            if( comput_i .and. .not. comput_j ) write(iout,9187)
            if( comput_j ) then
               write(iout,9220) "J     ", domain_id(1:8),
     &              (diterms(j),j=1,8), di_value_j, skipped_killed
            end if
            if( comput_i ) then
               write(iout,9220) "I_KI  ", domain_id(1:8),
     &              (iiterms(i,1),i=1,8), di_value_i(1), skipped_killed
               write(iout,9220) "I_KI  ", domain_id(1:8),
     &              (iiterms(i,2),i=1,8), di_value_i(2), skipped_killed
               write(iout,9220) "I_KII ", domain_id(1:8),
     &              (iiterms(i,3),i=1,8), di_value_i(3), skipped_killed
               write(iout,9220) "I_KII ", domain_id(1:8),
     &              (iiterms(i,4),i=1,8), di_value_i(4), skipped_killed
               write(iout,9220) "I_KIII", domain_id(1:8),
     &              (iiterms(i,5),i=1,8), di_value_i(5), skipped_killed
               write(iout,9220) "I_T11 ", domain_id(1:8),
     &              (iiterms(i,6),i=1,8), di_value_i(6), skipped_killed
               write(iout,9220) "I_T11 ", domain_id(1:8),
     &              (iiterms(i,7),i=1,8), di_value_i(7), skipped_killed
               write(iout,9220) "I_T13 ", domain_id(1:8),
     &              (iiterms(i,8),i=1,8), di_value_i(8), skipped_killed
            end if
         end if
c
         if( nowring.gt.0 ) then
            if( comput_j .and.       comput_i ) write(iout,9250)
            if( comput_j .and. .not. comput_i ) write(iout,9270)
            if( comput_i .and. .not. comput_j ) write(iout,9290)
            if( comput_j ) then
               write(iout,9300) "J     ", nowring, (diterms(i),i=1,8),
     &              di_value_j, skipped_killed
            end if
            if( comput_i ) then
               write(iout,9300) "I_KI  ", nowring,
     &              (iiterms(i,1),i=1,8), di_value_i(1), skipped_killed
               write(iout,9300) "I_KI  ", nowring,
     &              (iiterms(i,2),i=1,8), di_value_i(2), skipped_killed
               write(iout,9300) "I_KII ", nowring,
     &              (iiterms(i,3),i=1,8), di_value_i(3), skipped_killed
               write(iout,9300) "I_KII ", nowring,
     &              (iiterms(i,4),i=1,8), di_value_i(4), skipped_killed
               write(iout,9300) "I_KIII", nowring,
     &              (iiterms(i,5),i=1,8), di_value_i(5), skipped_killed
               write(iout,9300) "I_T11 ", nowring,
     &              (iiterms(i,6),i=1,8), di_value_i(6), skipped_killed
               write(iout,9300) "I_T11 ", nowring,
     &              (iiterms(i,7),i=1,8), di_value_i(7), skipped_killed
               write(iout,9300) "I_T13 ", nowring,
     &              (iiterms(i,8),i=1,8), di_value_i(8), skipped_killed
            end if
         end if
      end if
c
      return
c
 9100 format(/,1x,25x,'domain integral components',
     &  /,      1x,25x,'--------------------------')
 9110 format(7x,'element',5x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8' )
 9130 format(/,5x,' gauss point strains for element ',i7,', gpt ',i2,
     &       ':',/, 3(10x,3(e11.4,2x),/))
 9140 format(1x,a,1x,i7,8(1x,e11.4))
 9150 format('')
 9160 format(/,1x,'element totals:',3x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',8x,'total')
 9170 format(1x,a,7x,9(1x,e11.4))
 9180 format(/,1x,25x,'domain integral components',
     &  /,      1x,25x,'--------------------------')
 9185 format(8x,'domain',8x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',5x,'total J,I',
     &    2x,'killed ele' )
 9186 format(8x,'domain',8x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',7x,'total J',
     &    2x,'killed ele' )
 9187 format(8x,'domain',8x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',7x,'total I',
     &    2x,'killed ele' )
 9220 format(1x,a,1x,a8,9(1x,e11.4),2x,'(',i3,')')
 9250 format(8x,'domain',6x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',5x,'total J,I',
     &    2x,'killed ele' )
 9270 format(8x,'domain',6x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',7x,'total J',
     &    2x,'killed ele' )
 9290 format(8x,'domain',6x,'dm1',9x,'dm2',9x,'dm3',9x,'dm4',
     &    9x,'dm5',9x,'dm6',9x,'dm7',9x,'dm8',7x,'total I',
     &    2x,'killed ele' )
 9300 format(1x,a,1x,i7,9(1x,e11.4),2x,'(',i3,')')
 9400 format(/,1x,'area under q-function along crack front:  ',e11.4,
     &       /,1x,'length along crack front for this domain: ',e11.4,/)
c
      end subroutine dicmj_print_values
c
      end subroutine dicmj

c     ****************************************************************
c     *                                                              *
c     *                      dicmj_do_a_blk                          *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 6/23/2018 rhd              *
c     *                                                              *
c     *      Processing 1 domain and output values. Run MPI          *
c     *      parallel over (mpi) domains, threads over blocks        *
c     *      in each rank. In large models, many (MPI) domains       *
c     *      and element blocks have no elements within the J-II     *
c     *      domain and are skipped                                  *
c     *                                                              *
c     ****************************************************************
c
      subroutine dicmj_do_a_blk( blk, now_thread, diterms,
     &                           iiterms, message_count,
     &                           message_count2 )
c
      use global_data, only : myid, iout=>out, noelem, nonode, bits,
     a                        iprops, props, lprops, elblks, mxndel,
     b                        nstrs, mxgp, mxelpr, nstr,
     c                        worker_processor, numprocs,
     d                        scoord=>c, sdispl=>u, sveloc=>v,
     e                        saccel=>a
      use main_data, only   : incmap, elems_to_blocks, incid,
     a                        fgm_node_values, eq_node_force_indexes,
     b                        trn, trnmat,
     c                        temper_elems, temper_nodes,
     d                        temper_nodes_ref, eq_node_forces,
     e                        eq_node_force_len
      use elem_block_data, only : rot_n1_blocks,
     a                            urcs_n_blocks, cdest_blocks,
     b                            edest_blocks, eps_n_blocks,
     c                            initial_state_data
      use j_data, only : debug_driver, symmetric_domain,
     a  print_elem_values, q_element_maps, q_values, fgm_e, fgm_nu,
     b  block_seg_curves, seg_snode_nu, swd_at_nodes, strain_at_nodes,
     c  ignore_face_loads, omit_crack_front_elems, front_element_list,
     d  comput_i, cf_tractions, domain_rot, debug_elements,
     e  one_point_rule, e_front, nu_front, comput_j,
     f  cf_traction_flags, face_loading, process_temperatures,
     g  snode_alpha_ij, seg_snode_e, displ_grad_at_nodes,
     h  size_j_values, size_i_values, front_list_length,
     i  j_geonl_formulation, j_linear_formulation,
     j  process_initial_state, temperatures_on_model
c
      implicit none
c
c          parameters
c
      integer :: blk, now_thread, message_count, message_count2
      double precision :: diterms(size_j_values),
     &                    iiterms(size_i_values,size_i_values)
c
c          local declarations. includes pointers to simplify
c          addressing into blocks.
c
      double precision ::
     &   e_coord(3,mxndel), e_displ(3,mxndel), e_vel(3,mxndel),
     &   e_accel(3,mxndel), q_element(mxndel),
     &   e_stress(nstrs*mxgp), e_rots(9*mxgp), e_force(3,mxndel),
     &   symm_factor, e_node_temps(mxndel),
     &   elem_uniform_temp, e_alpha_ij(6,mxndel), eq_load_modifier,
     &   dummy, elem_nod_strains(6,mxndel), elem_nod_swd(mxndel),
     &   elem_nod_displ_derivs(9,mxndel), e_strain(9,mxgp), sign,
     &   e(mxndel), nu(mxndel), cf_load(3), e_W_is(mxgp)
c
      double precision :: e_jresults(size_j_values),
     &   e_iresults(size_i_values,size_i_values)
c
      integer :: eps_offset, gpn, node, node_id, etype,
     &           skipped_killed, ierr, elemno, num_enodes,
     &           num_gpts, rel_elem, i, j, i_elem,
     &           offset, element, numrow_sig, span, felem
      integer :: snodes(mxndel)
      integer, dimension (:,:), pointer :: edest, cdest
      real :: e_props(mxelpr)
      logical, external :: dibmck
      logical ::  geonl, chk_killed, omit_J7_J8_front_elems, ok,
     &            elem_temps, face_loads_possible, is_front_element,
     &            front_elem_flag, seg_curves_flag, brick, linearform,
     &            process_swd_derivs, process_strain_derivs,
     &            process_grad_derivs, process_blk
      double precision, parameter :: zero=0.0d0, one=1.0d0,
     &                               two=2.0d0, toler_static_j=1.0d-5
c
      span  = elblks(0,blk)
      felem = elblks(1,blk)
c
c          loop over all elements in this block. is there work to
c          do: (1) element is in domain, and (2) not killed
c
      process_blk = .false.
c
      do i_elem = 1, span
         elemno = felem + i_elem - 1
         if( .not. dibmck( elemno, q_element_maps, bits ) ) cycle
         if( chk_killed( elemno ) ) cycle
         process_blk = .true.
         exit
      end do
      if( .not. process_blk ) return
c
      symm_factor      = one
      if( symmetric_domain ) symm_factor = two
      process_swd_derivs    = size( swd_at_nodes ) == nonode
      process_strain_derivs = size( strain_at_nodes, 2 ) == nonode
      process_grad_derivs   = size( displ_grad_at_nodes, 2 ) == nonode
c
      do i_elem = 1, span
c
c          handle only elements in J-II domain
c
         elemno = felem + i_elem - 1
         if( .not. dibmck( elemno, q_element_maps, bits ) ) cycle
         if( chk_killed( elemno ) ) then
c$OMP ATOMIC UPDATE
            skipped_killed = skipped_killed + 1
            cycle
         end if
c
         etype      = iprops(1,elemno)
         brick      = etype .ge. 1  .and. etype .le. 5
         if( .not. brick ) then
c$OMP ATOMIC UPDATE
             message_count = message_count + 1
             if( message_count <=10 ) then
               write(iout,9200) elemno
               if( message_count == 10 ) write(iout,9210)
             end if
             cycle
         end if
c
         num_enodes = iprops(2,elemno)
         num_gpts   = iprops(6,elemno)
         geonl      = lprops(18,elemno)
         linearform = .not. geonl
         ok = .true.
         if( j_linear_formulation ) then  ! element must match domain
            if( geonl ) ok = .false.
         end if
         if( j_geonl_formulation ) then
            if( linearform ) ok = .false.
         end if
         if( .not. ok ) then
c$OMP ATOMIC UPDATE
             message_count2 = message_count2 + 1
             if( message_count2 <=10 ) then
               write(iout,9230) elemno
               if( message_count2 == 10 ) write(iout,9240)
             end if
             cycle
         end if
c
         rel_elem   = elemno - felem + 1
         cdest      => cdest_blocks(blk)%ptr
         edest      => edest_blocks(blk)%ptr
c
c          build copy of element coordinates, displacements,
c          velocities, accelerations, q-values from global data.
c          zero load terms that correspond to constrained dof.
c          if we have temperature loadings, get temps for element
c          nodes (node values + element uniform value). rotate
c          displacements, velocities and accelerations from
c          constraint-compatible to global coordinates. obtain
c          element nodal values of stress work density and displ
c          gradients structure node-value arrays.
c
         call dicmj_element_setup
c
c          crack-face tractions. the contribution to J arising
c          from crack-face tractions is calculated element-by-element
c          using the equivalent nodal loads on each element face
c          computed during setup of load step for applied pressures,
c          surface tractions and body forces. here we just get
c          the element equiv. nodal forces. they are passed to
c          element J routine which sorts out the loaded face.
c
c          a similar procedure is used to compute the contribution
c          to I.
c
         face_loads_possible = .not. ignore_face_loads .and.
     &                               eq_node_force_len .gt. 0
         if( face_loads_possible ) then
            if( eq_node_force_indexes(elemno) .ne. 0 ) then
               call vec_ops( e_force,  !    copy routine
     &              eq_node_forces(eq_node_force_indexes(elemno)),
     &              dummy, 3*num_enodes, 5 )
            end if
         end if
c
         is_front_element = .false.
         do i = 1, front_list_length
           if( front_element_list(i) == elemno ) then
             is_front_element = .true.
             exit
            end if
         end do
         omit_J7_J8_front_elems = omit_crack_front_elems .and.
     &                            is_front_element
c
c          gather element stresses
c
         offset = (rel_elem-1) * nstrs * num_gpts
         associate( urcs_n =>  urcs_n_blocks(blk)%ptr )
         do i = 1, nstrs * num_gpts
            e_stress(i) = urcs_n(offset+i)
         end do
         end associate

c          gather element properties
c
         e_props(1:mxelpr) = props(1:mxelpr,elemno)
c
c          gather 3x3 rotation matrices from polar decompositions
c          at each gauss point of element for geonl
c
         if( geonl ) then
           offset =  (rel_elem-1) * 9 * num_gpts
           associate( rots => rot_n1_blocks(blk)%ptr )
           do i = 1, 9 * num_gpts
             e_rots(i) = rots(offset+i)
           end do
           end associate
         end if
c
         e_strain = zero ! all terms
c
c          for I computations,
c          gather element strains at integration points.
c          and store in tensor form. convert engineering
c          (total) strains of off-diagonal terms to tensor strains.
c
c          for crack-face loading, make a copy of the tractions
c          input by the user in the domain definition. if none
c          was input, dielem_c.f automatically uses the equivalent
c          nodal loads used to solve the boundary value problem.
c
         if( comput_i ) call dicmj_more_i_setup
c
c          set flag for crack-front element.
c
         front_elem_flag = is_front_element
c
c          call the element routine to compute contribution
c          to the j-integral and or i-integral for domain
c
         element    = elemno  !  protect variables
         numrow_sig = nstrs   !       "
         call dielem( e_coord, q_element, e_displ, e_vel, e_accel,
     a                e_force, e_stress, e_props, e_props, e_props,
     b                e_rots, domain_rot, e_jresults, e_node_temps,
     c                elem_temps, e_alpha_ij, ierr, element, geonl,
     d                numrow_sig, snodes, e_W_is, elem_nod_swd,
     e                elem_nod_strains, elem_nod_displ_derivs,
     f                omit_J7_J8_front_elems, fgm_e,
     f                fgm_nu, e_strain, e, e_front, nu, nu_front,
     g                e_iresults, cf_traction_flags, cf_load,
     h                front_elem_flag, seg_curves_flag )
c
         if( comput_j ) then
            do i = 1, size_j_values
               e_jresults(i) = e_jresults(i) * symm_factor
               diterms(i)    = diterms(i) + e_jresults(i)
            end do
            if( print_elem_values .and. comput_j )
     &        write(iout,9140) "J     ", elemno,
     &                         e_jresults(1:size_j_values)
         end if
c
         if( comput_i ) then
            do i = 1, size_i_values
               do j = 1, size_i_values
                  e_iresults(i,j) = e_iresults(i,j) * symm_factor
                  iiterms(i,j)    = iiterms(i,j) + e_iresults(i,j)
               end do
            end do
         end if
c
         if( comput_i .and. symmetric_domain ) then
            iiterms(1:size_i_values,3:5) = zero
            iiterms(1:size_i_values,8)   = zero
         end if
c
         if( print_elem_values .and. comput_i ) then
            write(iout,9140) "I_KI  ", elemno, (e_iresults(i,1),i=1,8)
            write(iout,9140) "I_KI  ", elemno, (e_iresults(i,2),i=1,8)
            write(iout,9140) "I_KII ", elemno, (e_iresults(i,3),i=1,8)
            write(iout,9140) "I_KII ", elemno, (e_iresults(i,4),i=1,8)
            write(iout,9140) "I_KIII", elemno, (e_iresults(i,5),i=1,8)
            write(iout,9140) "I_T11 ", elemno, (e_iresults(i,6),i=1,8)
            write(iout,9140) "I_T11 ", elemno, (e_iresults(i,7),i=1,8)
            write(iout,9140) "I_T13 ", elemno, (e_iresults(i,8),i=1,8)
            write(iout,9150)
         end if
      end do  ! **** on all elements in block ****

      return
 9140 format(1x,a,1x,i7,8(1x,e11.4))
 9150 format('')
 9200 format(/,'>> Warning: only brick elements supported for domain',
     &  ' integrals. element: ',i8,
     & /,    '           element skipped.')

 9210 format(/,'>> Warning: *** no more messages about bricks ***')
 9230 format(/,'>> Warning: all elements in domain must have the same',
     &  ' formulation (small strain, larger strain. element: ',i8,
     & /,    '           element skipped.')
 9240 format(/,'>> Warning: *** no more messages about formulation',
     &   ' mismatch ***')

      contains
c     ========
c
c***************************************************************
c                                                              *
c      dicmj_do_a_blk -> contains dicmj_element_setup          *
c                                                              *
c        written by: rhd                                       *
c        last modified: 6/23/2018 rhd                          *
c                                                              *
c***************************************************************
c
      subroutine dicmj_element_setup
      implicit none
c
      integer :: incpos, k1, k2, i1, i2, i3, enode, snode
      logical, parameter :: local_debug = .true.
c
      seg_curves_flag = .false.
c
      incpos     = incmap(elemno)
      k1         = num_enodes
      k2         = 2*num_enodes
c
!DIR$ VECTOR ALIGNED
      do enode = 1, num_enodes
         e_coord(1,enode) = scoord(cdest(enode,rel_elem))
         e_coord(2,enode) = scoord(cdest(enode+k1,rel_elem))
         e_coord(3,enode) = scoord(cdest(enode+k2,rel_elem))
         snode            = incid(incpos+enode-1)
         snodes(enode)    = snode
         q_element(enode) = q_values(snode)
         i1               = edest(enode,   rel_elem)
         i2               = edest(k1+enode,rel_elem)
         i3               = edest(k2+enode,rel_elem)
         e_displ(1,enode) = sdispl(i1)
         e_displ(2,enode) = sdispl(i2)
         e_displ(3,enode) = sdispl(i3)
         e_vel(1,enode)   = sveloc(i1)
         e_vel(2,enode)   = sveloc(i2)
         e_vel(3,enode)   = sveloc(i3)
         e_accel(1,enode) = saccel(i1)
         e_accel(2,enode) = saccel(i2)
         e_accel(3,enode) = saccel(i3)
         e(enode)         = props(7,elemno)
         nu(enode)        = props(8,elemno)
         if( fgm_e )  e(enode)  = fgm_node_values(snode,1)
         if( fgm_nu ) nu(enode) = fgm_node_values(snode,2)
         if( temperatures_on_model .and.
     &       allocated( block_seg_curves ) ) then
            if( block_seg_curves(blk) ) then
               seg_curves_flag = .true.
               e(enode)        = seg_snode_e(snode)
               nu(enode)       = seg_snode_nu(snode)
            end if
         end if
c
c         if necessary, transform nodal values from
c         constraint-compatible coordinates to global
c         coordinates.
c
         if( trn(snode) ) then
            call di_trans_nodvals( e_displ(1,enode),
     &                             trnmat(snode)%mat(1,1))
            call di_trans_nodvals( e_vel(1,enode),
     &                             trnmat(snode)%mat(1,1))
            call di_trans_nodvals( e_accel(1,enode),
     &                             trnmat(snode)%mat(1,1))
         end if
c
         e_force(1,enode)          = zero
         e_force(2,enode)          = zero
         e_force(3,enode)          = zero
         e_node_temps(enode)       = zero
         e_alpha_ij(1:6,enode)     = zero
         elem_nod_swd(enode)       = zero
         elem_nod_strains(1:6,enode) = zero
         elem_nod_displ_derivs(1:9,enode) = zero
c
      end do ! on enode
c

      if( process_swd_derivs ) then
!DIR$ VECTOR ALIGNED
        do enode = 1, num_enodes
          snode = incid(incpos+enode-1)
          elem_nod_swd(enode) = swd_at_nodes(snode)
        end do
      end if
c
      if( process_strain_derivs ) then
        do enode = 1, num_enodes
          snode = incid(incpos+enode-1)
!DIR$ VECTOR ALIGNED
          elem_nod_strains(1:6,enode) = strain_at_nodes(1:6,snode)
        end do
      end if
c
      if( process_grad_derivs ) then
        do enode = 1, num_enodes
          snode = incid(incpos+enode-1)
!DIR$ VECTOR ALIGNED
          elem_nod_displ_derivs(1:9,enode) =
     &               displ_grad_at_nodes(1:9,snode)
        end do
      end if
c
c        for problems with temperature loads, pull out
c        current temperatures of element nodes and set the thermal
c        expansion coefficients at element nodes. remove reference
c        temperatures of model nodes. the global temperatures flag
c        refers to increment temps for step just completed. cannot use
c        it since early application of temps may be followed by only
c        mechanical loads
c
      elem_temps = .false.
      if( temperatures_on_model ) then
        elem_uniform_temp = temper_elems(elemno)
!DIR$ VECTOR ALIGNED
        do enode = 1, num_enodes
         snode = incid(incpos + enode - 1)
         e_node_temps(enode) = temper_nodes(snode) + elem_uniform_temp
     &                        - temper_nodes_ref(snode)
         if( abs(e_node_temps(enode)) > zero ) elem_temps = .true.
        end do
        if( allocated( snode_alpha_ij ) ) then
         do enode = 1, num_enodes
          snode = incid( incpos + enode - 1 )
!DIR$ VECTOR ALIGNED
          e_alpha_ij(1:6,enode) = snode_alpha_ij(snode,1:6)
         end do
        end if
      end if
c
c        setup vector of energy density values at element
c        integration points at user-defined initial state
c        if required. otherwise set zero vector to eliminate
c        logic in element computational routines.
c
      if( process_initial_state ) then
        do gpn = 1, num_gpts
         e_W_is(gpn) =
     &     initial_state_data(blk)%W_plastic_nis_block(i_elem,gpn)
        end do

        if( local_debug .and.
     &      (elemno == 8955 .or. elemno == 9060 ) ) then
          write(iout,*) ' @ 1. dicmj_element_setup. elem: ',elemno
          do gpn = 1, num_gpts
           write(iout,9000)  gpn, e_W_is(gpn)
          end do
        end if
      else
          e_W_is = zero
      end if
 9000 format(10x,i3,f15.8)
c
      return
      end subroutine dicmj_element_setup
c
c***************************************************************
c                                                              *
c      dicmj -> contains dicmj_more_i_setup                    *
c                                                              *
c        written by: rhd                                       *
c        last modified: 3/30/2018 rhd                          *
c                                                              *
c***************************************************************
c
      subroutine dicmj_more_i_setup
      implicit none

c
c          gather element strains at integration points.
c          and store in tensor form. convert engineering
c          (total) strains of off-diagonal terms to tensor strains.
c
      eps_offset = (rel_elem - 1) * nstr * num_gpts
      associate( eps => eps_n_blocks(blk)%ptr )
c
!DIR$ VECTOR ALIGNED
      do gpn = 1, num_gpts
         e_strain(1,gpn) = eps(eps_offset + 1)
         e_strain(2,gpn) = eps(eps_offset + 4)/two
         e_strain(3,gpn) = eps(eps_offset + 6)/two
         e_strain(4,gpn) = eps(eps_offset + 4)/two
         e_strain(5,gpn) = eps(eps_offset + 2)
         e_strain(6,gpn) = eps(eps_offset + 5)/two
         e_strain(7,gpn) = eps(eps_offset + 6)/two
         e_strain(8,gpn) = eps(eps_offset + 5)/two
         e_strain(9,gpn) = eps(eps_offset + 3)
         eps_offset      = eps_offset + nstr
      end do
c
      end associate
c
      if( debug_driver ) then
         do gpn = 1, num_gpts
            write(iout,9130) elemno, gpn, (e_strain(i,gpn),i=1,9)
         end do
      end if
c
c          for crack-face loading, make a copy of the tractions
c          input by the user in the domain definition. if none
c          was input, dielem_c.f automatically uses the equivalent
c          nodal loads used to solve the boundary value problem.
c
      cf_load(1) = cf_tractions(1)
      cf_load(2) = cf_tractions(2)
      cf_load(3) = cf_tractions(3)
c
      return
 9130 format(/,5x,' gauss point strains for element ',i7,', gpt ',i2,
     &       ':',/, 3(10x,3(e11.4,2x),/))

      end subroutine  dicmj_more_i_setup
c
      end subroutine dicmj_do_a_blk

c***************************************************************
c                                                              *
c subroutine to transform a 3x1 vector of constraint-          *
c compatible-coordinate-system values to global-coordinate-    *
c system values. the routine premultiplies the incoming        *
c constraint-compatible values by the transpose of the stored  *
c global-to-constraint coordinate system rotation matrix.      *
c                                                              *
c                written by: mcw                               *
c                last modified: 3/26/2018 rhd                  *
c                                                              *
c***************************************************************
c
      subroutine di_trans_nodvals( vec, transmat )
      implicit none
      double precision :: vec(3), transmat(3,3)
      double precision :: tempvec(3)
c
      tempvec(1) = transmat(1,1) * vec(1) + transmat(2,1) * vec(2)
     &           + transmat(3,1) * vec(3)
      tempvec(2) = transmat(1,2) * vec(1) + transmat(2,2) * vec(2)
     &           + transmat(3,2) * vec(3)
      tempvec(3) = transmat(1,3) * vec(1) + transmat(2,3) * vec(2)
     &           + transmat(3,3) * vec(3)
c
      vec(1) = tempvec(1)
      vec(2) = tempvec(2)
      vec(3) = tempvec(3)
c
      return
      end


!-------------------------------------------------------------------------------
!> Module basic state
!!
!! @par Description
!!          This module is for the set of basic state for non-hydrostatic model
!!
!! @author NICAM developers, Team SCALE
!<
!-------------------------------------------------------------------------------
module mod_bsstate
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof

  use mod_adm, only: &
     ADM_LOG_FID
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters
  !
  ! < NONE >
  !-----------------------------------------------------------------------------
  !
  !++ Public variables
  !
  !
  !--- density
  real(RP),allocatable, public :: rho_bs(:,:,:)
  real(RP),allocatable, public :: rho_bs_pl(:,:,:)
  !
  !--- pressure
  real(RP),allocatable, public :: pre_bs(:,:,:)
  real(RP),allocatable, public :: pre_bs_pl(:,:,:)
  !
  !--- temperature
  real(RP),allocatable, public :: tem_bs(:,:,:)
  real(RP),allocatable, public :: tem_bs_pl(:,:,:)
  !
  !--- pot temperature
  real(RP),allocatable, public :: th_bs(:,:,:)
  real(RP),allocatable, public :: th_bs_pl(:,:,:)
  !
  !--- water vap.
  real(RP),allocatable, public :: qv_bs(:,:,:)
  real(RP),allocatable, public :: qv_bs_pl(:,:,:)
  !
  !--- geo-potential ( g X z )
  real(RP),allocatable, private :: phi(:,:,:)
  real(RP),allocatable, private :: phi_pl(:,:,:)
  !
  !--- Basic state type
  character(len=H_SHORT), public :: ref_type = 'NOBASE'
  !                                  ='TEM': temerature is given.
  !                                  ='TH' : potential temperature is given.
  !                                  ='NOBASE' : no basic state
  !                                  ='INPUT'  : input
  !
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: bsstate_setup
  public :: bsstate_input_ref
  public :: bsstate_output_ref
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters
  !
  !--- reference pressure at the ground
  real(RP), private :: pre_g = 101325.0_RP
  !
  !--- reference temperature at the ground
  real(RP), private :: tem_g = 300.0_RP
  !
  !--- reference pot. temperature at the ground
  real(RP), private :: th_g = 300.0_RP
  !
  !--- reference density at the ground ( calculated by using pre_g & tem_g )
  real(RP), private :: rho_g
  !
  !--- reference Brunt-Vaisala frequency ( used if ref_type = 'TH'. )
  real(RP), private :: BV_freq = 0.0_RP
  !
  !--- lapse rate ( used if ref_type = 'TEM'. )
  real(RP), private :: TGAMMA = 0.0_RP
  !
  !--- lower boundary of constant (potential) temperature
  real(RP), private :: ZT = 0.0_RP
  !
  !--- geopotential at the ground
  real(RP), parameter, public :: PHI0=0.0_RP
  !-----------------------------------------------------------------------------
  !
  !++ Private variables
  !
  !--- reference phi
  real(RP), allocatable, private :: phi_ref(:)
  !
  !--- reference density
  real(RP), allocatable, private :: rho_ref(:)
  !
  !--- reference pressure
  real(RP), allocatable, private :: pre_ref(:)
  !
  !--- reference temperature
  real(RP), allocatable, private :: tem_ref(:)
  !
  !--- water vapor
  real(RP), allocatable, private :: qv_ref(:)
  !
  !--- reference potential temperature
  real(RP), allocatable, private :: th_ref(:)
  !
  character(len=H_LONG), private :: ref_fname = 'ref.dat'
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures
  !
  private :: set_referencestate
  private :: set_basicstate
  private :: output_info
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine bsstate_setup
    use mod_adm, only: &
       ADM_CTL_FID,   &
       ADM_proc_stop, &
       ADM_lall,      &
       ADM_lall_pl,   &
       ADM_kall,      &
       ADM_gall_pl,   &
       ADM_gall
    implicit none

    namelist / BSSTATEPARAM / &
         ref_type, & !--- type of basic state
         ZT,       & !--- if z>ZT, equi-temperature
         pre_g,    & !--- reference pressure
         tem_g,    & !--- reference temperature
         TGAMMA,   & !--- lapse rate when ref_type='TEM'.
         th_g,     & !--- reference potential temp. for when ref_type='TH'
         BV_freq,  & !--- Vaisala freq when ref_type='TH'
         ref_fname   !--- in/output base name if necessary.

    integer :: ierr
    !---------------------------------------------------------------------------

    !--- read parameters
    write(ADM_LOG_FID,*)
    write(ADM_LOG_FID,*) '+++ Module[basic state]/Category[nhm share]'
    rewind(ADM_CTL_FID)
    read(ADM_CTL_FID,nml=BSSTATEPARAM,iostat=ierr)
    if ( ierr < 0 ) then
       write(ADM_LOG_FID,*) '*** BSSTATEPARAM is not specified. use default.'
    elseif( ierr > 0 ) then
       write(*,          *) 'xxx Not appropriate names in namelist BSSTATEPARAM. STOP.'
       write(ADM_LOG_FID,*) 'xxx Not appropriate names in namelist BSSTATEPARAM. STOP.'
       call ADM_proc_stop
    endif
    write(ADM_LOG_FID,nml=BSSTATEPARAM)

    !--- allocation of reference variables
    allocate(phi_ref(ADM_kall))
    allocate(rho_ref(ADM_kall))
    allocate(pre_ref(ADM_kall))
    allocate(tem_ref(ADM_kall))
    allocate(th_ref(ADM_kall))
    allocate(qv_ref(ADM_kall))
    !
    ! add by kgoto
    ! initialize
    phi_ref=0.0_RP
    rho_ref=0.0_RP
    pre_ref=0.0_RP
    tem_ref=0.0_RP
    th_ref=0.0_RP
    !--- allocation of the basic variables
    allocate(rho_bs(ADM_gall,ADM_kall,ADM_lall))
    allocate(rho_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    allocate(pre_bs(ADM_gall,ADM_kall,ADM_lall))
    allocate(pre_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    allocate(tem_bs(ADM_gall,ADM_kall,ADM_lall))
    allocate(tem_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    allocate(th_bs(ADM_gall,ADM_kall,ADM_lall))
    allocate(th_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    allocate(qv_bs(ADM_gall,ADM_kall,ADM_lall))
    allocate(qv_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    allocate(phi(ADM_gall,ADM_kall,ADM_lall))
    allocate(phi_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl))
    !
    ! add by kgoto
    ! initialize
    rho_bs    = 0.0_RP
    rho_bs_pl = 0.0_RP
    pre_bs    = 0.0_RP
    pre_bs_pl = 0.0_RP
    tem_bs    = 0.0_RP
    tem_bs_pl = 0.0_RP
    th_bs    = 0.0_RP
    th_bs_pl = 0.0_RP
    qv_bs    = 0.0_RP
    qv_bs_pl = 0.0_RP
    !
    if ( ref_type=='INPUT') then
       !
       !---- input reference state
       call bsstate_input_ref(ref_fname)
       !
       !--- calculation of basic state
       call set_basicstate
    else !--- other type
       !
       !--- calculation of reference state
       call set_referencestate
       !
       !--- calculation of basic state
       call set_basicstate
    endif
    !
    !--- output the information
    call output_info

    return
  end subroutine bsstate_setup

  !-----------------------------------------------------------------------------
  subroutine output_info
    use mod_adm, only: &
       ADM_LOG_FID, &
       ADM_kall,    &
       ADM_kmin,    &
       ADM_kmax
    implicit none

    integer :: k
    !---------------------------------------------------------------------------

    write(ADM_LOG_FID,*) 'Msg : Sub[nhm_bs_output_info]/Mod[basicstate]'
    write(ADM_LOG_FID,*) ' --- Basic state type         : ', trim(ref_type)
    write(ADM_LOG_FID,*) ' --- Reference pressure       : ', pre_g
    write(ADM_LOG_FID,*) ' --- Reference temperature    : ', tem_g
    write(ADM_LOG_FID,*) ' --- Reference density        : ', rho_g
    write(ADM_LOG_FID,*) ' --- Vaisala frequency        : ', BV_freq
    write(ADM_LOG_FID,*) ' --- Lapse rate of temperature: ', TGAMMA
    write(ADM_LOG_FID,*) ' --- Effective height         : ', ZT

    write(ADM_LOG_FID,*) '-------------------------------------------------------'
    write(ADM_LOG_FID,*) 'Level   Density  Pressure     Temp. Pot. Tem.        qv'
    do k=1,ADM_kall
       write(ADM_LOG_FID,'(I4,F12.4,F10.2,F10.2,F10.2,F10.7)') &
                         k, rho_ref(k), pre_ref(k), tem_ref(k),th_ref(k), qv_ref(k)
       if (  k == ADM_kmin-1 ) write(ADM_LOG_FID,*) '-------------------------------------------------------'
       if (  k == ADM_kmax   ) write(ADM_LOG_FID,*) '-------------------------------------------------------'
    enddo

    return
  end subroutine output_info

  !-----------------------------------------------------------------------------
  subroutine set_referencestate
    use scale_const, only: &
       CONST_GRAV,  &
       CONST_Rdry,  &
       CONST_Rvap,  &
       CONST_CPdry, &
       CONST_PRE00
    use mod_adm, only: &
       ADM_have_pl, &
       ADM_kall,       &
       ADM_kmin,       &
       ADM_kmax
    use mod_grd, only :  &
         GRD_gz,         &
         GRD_dgz,        &
         GRD_gzh,        &
         GRD_afac,       &
         GRD_bfac
    implicit none

    real(RP) :: dpre_ref_k
    real(RP) :: pre_s, rho_s, total_mass0, total_mass, mass_diff_ratio

    real(RP) :: kappa

    integer :: k
    !---------------------------------------------------------------------------

    kappa = CONST_Rdry / CONST_CPdry

    !--- calculation of reference geopotential
    do k=1,ADM_kall
       phi_ref(k) = CONST_GRAV * GRD_gz(k)
    enddo
    !
    if ( ref_type=='NOBASE') then
       !
       phi_ref = 0.0_RP
       rho_ref = 0.0_RP
       pre_ref = 0.0_RP
       tem_ref = 0.0_RP
       th_ref  = 0.0_RP
       qv_ref  = 0.0_RP
       !
       pre_bs    = 0.0_RP
       pre_bs_pl = 0.0_RP
       tem_bs    = 0.0_RP
       tem_bs_pl = 0.0_RP
       th_bs    = 0.0_RP
       th_bs_pl = 0.0_RP
       qv_bs    = 0.0_RP
       qv_bs_pl = 0.0_RP
       rho_bs    = 0.0_RP
       rho_bs_pl = 0.0_RP
       !
       ! 04/12/25 M.Satoh add
       if ( tem_g /= 0.0_RP ) then
          rho_g = pre_g / CONST_Rdry / tem_g
       else
          rho_g = 0.0_RP
       endif
       !
    else if ( ref_type == 'TEM' ) then
       qv_ref = 0.0_RP
       !
       !---  calculation of reference temperature
       do k=1,ADM_kall
          if ( GRD_gz(k) <=ZT ) then
             tem_ref(k) = tem_g - TGAMMA * GRD_gz(k)
          else
             tem_ref(k) = tem_g - TGAMMA * ZT
          endif
       enddo
       !
       !--- calculation of density at the surface
       rho_g = pre_g / CONST_Rdry / tem_g
       !
       !--- calculation of reference pressure and density
       !--- just below the ground level
       pre_ref(ADM_kmin-1)                                &
            = pre_g                                        &
            + 0.5_RP                                       &
            * ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) &
            * rho_g
       rho_ref(ADM_kmin-1)        &
            = pre_ref(ADM_kmin-1) &
            / CONST_Rdry           &
            / tem_ref(ADM_kmin-1)
       !
       !--- Reference pressure and density at the first level
       pre_ref(ADM_kmin)                                        &
            = pre_ref(ADM_kmin-1)                               &
            - ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) * rho_g
       rho_ref(ADM_kmin)        &
            = pre_ref(ADM_kmin) &
            / CONST_Rdry         &
            / tem_ref(ADM_kmin)
       !
       !--- Reference pressure and density at k level
       !---    In this caluculation, the hydrostatic balance equation
       !---    ( dP/dz=-RHO dPHI/dz ) is applied at the half integer
       !---    level ( k-1/2 ). RHO is obtained by extrapolation from
       !---    the values at lower level.
       !---
       !--- Consistent way(?) in the scheme.
       !---
       !--- pre_ref(k) - pre_ref(k-1)
       !--- = - 0.5_RP * ( GRD_afac(k) * rho_ref(k)
       !---              +GRD_bfac(k) * rho_ref(k-1)  )
       !---   * ( phi_ref(k) - phi_ref(k-1) )
       !---
       !--- rho_ref(k)*CONST_Rdry*tem_ref(k)  - pre_ref(k-1)
       !--- = - 0.5_RP * ( GRD_afac(k) * rho_ref(k)
       !---              +GRD_bfac(k) * rho_ref(k-1)  )
       !---   * ( phi_ref(k) - phi_ref(k-1) )
       !
       !--- rho_ref(k)*( CONST_Rdry*tem_ref(k)
       !---            + 0.5_RP * GRD_afac(k)
       !---            * ( phi_ref(k) - phi_ref(k-1) )
       !---            )
       !--- = pre_ref(k-1)
       !---            - 0.5_RP * GRD_bfac(k) * rho_ref(k-1)
       !---            * ( phi_ref(k) - phi_ref(k-1) )
       !---
       do k = ADM_kmin+1, ADM_kmax+1
          rho_ref(k) = &
               ( pre_ref(k-1) &
               - 0.5_RP * GRD_bfac(k) * rho_ref(k-1) &
               * ( phi_ref(k) - phi_ref(k-1) )&
               ) / &
               ( CONST_Rdry*tem_ref(k) &
               + 0.5_RP * GRD_afac(k)  &
               * ( phi_ref(k) - phi_ref(k-1) )  &
               )
          pre_ref(k) = rho_ref(k) * CONST_Rdry * tem_ref(k)
       enddo
       !
       !--- calculation of reference potential temperature
       do k = 1, ADM_kall
          th_ref(k)                                        &
               = tem_ref(k)                                &
               * ( CONST_PRE00 / pre_ref(k) )**kappa
       enddo
       !
    else if ( ref_type == 'RHO' ) then
       qv_ref = 0.0_RP
       !
       !---  calculation of reference density
       total_mass0 = CONST_PRE00/CONST_GRAV
       pre_s = CONST_PRE00
       do
          do k = ADM_kmin-1, ADM_kmax+1
             rho_ref(k) = pre_s/CONST_Rdry/tem_g / exp(CONST_GRAV*GRD_gz(k)/CONST_Rdry/tem_g)
          enddo
          total_mass = 0.0_RP
          do k = ADM_kmin, ADM_kmax
             total_mass = total_mass + GRD_dgz(k)*rho_ref(k)
          enddo
          mass_diff_ratio = total_mass0/total_mass
          if ( abs(mass_diff_ratio-1.0_RP)<1.E-8_RP) then
             exit
          else
             pre_s = pre_s * mass_diff_ratio
          endif
       enddo
       !
       !--- calculation of density at the surface
       rho_s = pre_s /CONST_Rdry / tem_g
       !
       !--- calculation of reference pressure and density
       !--- just below the ground level
       pre_ref(ADM_kmin-1)                                &
            = pre_s                                       &
            + 0.5_RP                                       &
            * ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) &
            * rho_s
       !
       !--- Reference pressure and density at the first level
       pre_ref(ADM_kmin)                                        &
            = pre_ref(ADM_kmin-1)                               &
            - ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) * rho_s
       !
       !--- Reference pressure and density at k level
       do k = ADM_kmin+1, ADM_kmax+1
          pre_ref(k) = pre_ref(k-1) &
               - 0.5_RP * ( GRD_afac(k) * rho_ref(k)     &
                          +GRD_bfac(k) * rho_ref(k-1)  )&
               * ( phi_ref(k) - phi_ref(k-1) )
       enddo
       !
       !--- calculation of reference temperature & pot temperature
       do k = 1, ADM_kall
          tem_ref(k) = pre_ref(k) / rho_ref(k) / CONST_Rdry
          th_ref(k)                                        &
               = tem_ref(k)                                &
               * ( CONST_PRE00 / pre_ref(k) )**kappa
       enddo
       !
    else if ( ref_type == 'TH' ) then
       qv_ref = 0.0_RP
       !
       !--- calculation of reference pot. temp.
       !--- just below the surface level.
       th_ref(ADM_kmin-1)                                 &
            = th_g                                         &
            / exp ( BV_freq**2 / CONST_GRAV                     &
                   * ( GRD_gzh(ADM_kmin) - GRD_gz(ADM_kmin-1) ) )
       !
       !--- calculation of reference pot. temp. at the first level.
       th_ref(ADM_kmin)                                   &
            = th_g                                         &
            * exp ( BV_freq**2 / CONST_GRAV                     &
                   * ( GRD_gz(ADM_kmin) - GRD_gzh(ADM_kmin) ) )
       !
       !--- calculation of reference pot. temp. at k level
       do k = ADM_kmin+1, ADM_kmax+1
          if ( GRD_gz(k) <= ZT ) then
             th_ref(k) = th_ref(k-1)                     &
                  * exp ( BV_freq**2 / CONST_GRAV              &
                         * ( GRD_gz(k) - GRD_gz(k-1) ) )
          else
             th_ref(k) = th_ref(k-1)
          endif
       enddo
       !
       !--- calculation of density at the surface
       tem_g = th_g / ( CONST_PRE00 / pre_g )**kappa
       rho_g = pre_g / CONST_Rdry / tem_g
       !
       !--- calculation of reference pressure, temperature, density
       !--- just below the ground level.
       pre_ref(ADM_kmin-1)                                &
            = pre_g                                        &
            + 0.5_RP                                       &
            * ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) &
            * rho_g
       tem_ref(ADM_kmin-1)                                        &
            = th_ref(ADM_kmin-1)                                  &
            / ( CONST_PRE00 / pre_ref(ADM_kmin-1) )**kappa
       rho_ref(ADM_kmin-1)        &
            = pre_ref(ADM_kmin-1) &
            / CONST_Rdry           &
            / tem_ref(ADM_kmin-1)
       !
       !--- calculation of reference pressure and density
       !--- at the first level
       pre_ref(ADM_kmin)                                         &
            = pre_ref(ADM_kmin-1)                                &
            - ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) * rho_g
       tem_ref(ADM_kmin)                                       &
            = th_ref(ADM_kmin)                                 &
            / ( CONST_PRE00 / pre_ref(ADM_kmin) )**kappa
       rho_ref(ADM_kmin)                                       &
            = pre_ref(ADM_kmin) / CONST_Rdry / tem_ref(ADM_kmin)
       !
       !--- Reference pressure and density at k level
       !---    In this caluculation, the hydrostatic balance equation
       !---    ( dP/dz=-RHO dPHI/dz ) is applied at the half integer
       !---    level ( k-1/2 ). RHO is obtained by extrapolation from
       !---    the values at lower level.
       !
       !--- fist guess
       do k = ADM_kmin+1, ADM_kmax+1
          pre_ref(k) = pre_ref(k-1)              &
               - ( phi_ref(k) - phi_ref(k-1) )   &
               * ( rho_ref(k-1)                  &
               + ( rho_ref(k-1) - rho_ref(k-2) ) &
               / ( GRD_gz(k-1)  - GRD_gz(k-2) )   &
               * ( GRD_gz(k)    - GRD_gz(k-1) ) * 0.5_RP )
          tem_ref(k)                                      &
               = th_ref(k)                                &
               / ( CONST_PRE00 / pre_ref(k) )**kappa
          rho_ref(k)        &
               = pre_ref(k) &
               / CONST_Rdry  &
               / tem_ref(k)
       enddo
       !--- hydro static balance adjustment
       do k = ADM_kmin+1, ADM_kmax+1
          do
             tem_ref(k) = th_ref(k)                                &
                  / ( CONST_PRE00 / pre_ref(k) )**kappa
             rho_ref(k) = &
                  ( pre_ref(k-1) &
                  - 0.5_RP * GRD_bfac(k) * rho_ref(k-1) &
                  * ( phi_ref(k) - phi_ref(k-1) )&
                  ) / &
                  ( CONST_Rdry*tem_ref(k) &
                  + 0.5_RP * GRD_afac(k)  &
                  * ( phi_ref(k) - phi_ref(k-1) )  &
                  )
             dpre_ref_k = rho_ref(k) * CONST_Rdry * tem_ref(k) - pre_ref(k)
             pre_ref(k) = pre_ref(k)+ dpre_ref_k
             if ( abs(dpre_ref_k) < 1.E-10_RP ) exit
             if ( ADM_have_pl ) then
                write(*,*) k,abs(dpre_ref_k)
             endif
          enddo
       enddo
    else if ( ref_type == 'TH-SP' ) then
       qv_ref = 0.0_RP
       !
       !--- calculation of reference pot. temp.
       !--- just below the surface level.
       do k=ADM_kmin-1,ADM_kmax+1
          if ( GRD_gz(k)<10000.0_RP) then
             th_ref(k) = th_g
          else
             th_ref(k) = th_g+10.0_RP/1000.0_RP*(GRD_gz(k)-10000.0_RP)
          endif
       enddo
       !
       !--- calculation of density at the surface
       tem_g = th_g / ( CONST_PRE00 / pre_g )**kappa
       rho_g = pre_g / CONST_Rdry / tem_g
       !
       !--- calculation of reference pressure, temperature, density
       !--- just below the ground level.
       pre_ref(ADM_kmin-1)                                &
            = pre_g                                        &
            + 0.5_RP                                       &
            * ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) &
            * rho_g
       tem_ref(ADM_kmin-1)                                        &
            = th_ref(ADM_kmin-1)                                  &
            / ( CONST_PRE00 / pre_ref(ADM_kmin-1) )**kappa
       rho_ref(ADM_kmin-1)        &
            = pre_ref(ADM_kmin-1) &
            / CONST_Rdry           &
            / tem_ref(ADM_kmin-1)
       !
       !--- calculation of reference pressure and density
       !--- at the first level
       pre_ref(ADM_kmin)                                         &
            = pre_ref(ADM_kmin-1)                                &
            - ( phi_ref(ADM_kmin) - phi_ref(ADM_kmin-1) ) * rho_g
       tem_ref(ADM_kmin)                                       &
            = th_ref(ADM_kmin)                                 &
            / ( CONST_PRE00 / pre_ref(ADM_kmin) )**kappa
       rho_ref(ADM_kmin)                                       &
            = pre_ref(ADM_kmin) / CONST_Rdry / tem_ref(ADM_kmin)
       !
       !--- Reference pressure and density at k level
       !---    In this caluculation, the hydrostatic balance equation
       !---    ( dP/dz=-RHO dPHI/dz ) is applied at the half integer
       !---    level ( k-1/2 ). RHO is obtained by extrapolation from
       !---    the values at lower level.
       !
       !--- fist guess
       do k = ADM_kmin+1, ADM_kmax+1
          pre_ref(k) = pre_ref(k-1)              &
               - ( phi_ref(k) - phi_ref(k-1) )   &
               * ( rho_ref(k-1)                  &
               + ( rho_ref(k-1) - rho_ref(k-2) ) &
               / ( GRD_gz(k-1)  - GRD_gz(k-2) )   &
               * ( GRD_gz(k)    - GRD_gz(k-1) ) * 0.5_RP )
          tem_ref(k)                                      &
               = th_ref(k)                                &
               / ( CONST_PRE00 / pre_ref(k) )**kappa
          rho_ref(k)        &
               = pre_ref(k) &
               / CONST_Rdry  &
               / tem_ref(k)
       enddo
       !--- hydro static balance adjustment
       do k = ADM_kmin+1, ADM_kmax+1
          do
             tem_ref(k) = th_ref(k)                                &
                  / ( CONST_PRE00 / pre_ref(k) )**kappa
             rho_ref(k) = &
                  ( pre_ref(k-1) &
                  - 0.5_RP * GRD_bfac(k) * rho_ref(k-1) &
                  * ( phi_ref(k) - phi_ref(k-1) )&
                  ) / &
                  ( CONST_Rdry*tem_ref(k) &
                  + 0.5_RP * GRD_afac(k)  &
                  * ( phi_ref(k) - phi_ref(k-1) )  &
                  )
             dpre_ref_k = rho_ref(k) * CONST_Rdry * tem_ref(k) - pre_ref(k)
             pre_ref(k) = pre_ref(k)+ dpre_ref_k
             if ( abs(dpre_ref_k) < 1.E-10_RP ) exit
             if ( ADM_have_pl ) then
                write(*,*) k,abs(dpre_ref_k)
             endif
          enddo
       enddo
    else if ( ref_type == 'OOYAMA' ) then
       call ooyama_reference
       do k = 1, ADM_kall
          pre_ref(k) = rho_ref(k) * tem_ref(k) &
               * ( (1.0_RP-qv_ref(k))*CONST_Rdry+qv_ref(k)*CONST_Rvap )
          th_ref(k)                                        &
               = tem_ref(k)                                &
               * ( CONST_PRE00 / pre_ref(k) )**kappa
       enddo
    endif

!   if ( ref_type == 'GCSS_CASE1' ) then
    if ( ref_type == 'GCSS_CASE1' .or. ref_type=='TWP-ICE') then ! 11/08/13 A.Noda [add]
       call gcss_reference
       do k = 1, ADM_kall
          tem_ref(k) = th_ref(k)                                &
               / ( CONST_PRE00 / pre_ref(k) )**kappa
          rho_ref(k) = pre_ref(k)/tem_ref(k) &
               / ( (1.0_RP-qv_ref(k))*CONST_Rdry+qv_ref(k)*CONST_Rvap )
       enddo
    endif

  end subroutine set_referencestate

  !-----------------------------------------------------------------------------
  subroutine gcss_reference
    implicit none

    integer :: fid

    fid = IO_get_available_fid()
    Open(fid,file=Trim(ref_fname),status='old',form='unformatted')
    read(fid) th_ref(:)
    read(fid) pre_ref(:)
    read(fid) qv_ref(:)
    close(fid)

  end subroutine gcss_reference

  !-----------------------------------------------------------------------------
  subroutine ooyama_reference
    use mod_adm, only: &
       ADM_kmin, &
       ADM_kmax
    use mod_grd, only: &
       GRD_gz
    implicit none

    character(len=H_LONG) :: fname = 'ooyama_profile.dat'

    real(RP), allocatable :: z_s  (:)
    real(RP), allocatable :: rho_s(:)
    real(RP), allocatable :: tem_s(:)
    real(RP), allocatable :: qv_s (:)

    integer :: fid
    integer :: kmax
    integer :: k, kk, kp

    real(RP) :: lag_intpl
    real(RP) :: z,z1,p1,z2,p2,z3,p3
    lag_intpl(z,z1,p1,z2,p2,z3,p3) = ((z-z2)*(z-z3))/((z1-z2)*(z1-z3))*p1 &
                                   + ((z-z1)*(z-z3))/((z2-z1)*(z2-z3))*p2 &
                                   + ((z-z1)*(z-z2))/((z3-z1)*(z3-z2))*p3
    !---------------------------------------------------------------------------

    !--- read sounding data ( ooyama(2001) )
    fid = IO_get_available_fid()
    open( unit   = fid,         &
          file   = trim(fname), &
          status = 'old',       &
          form   = 'unformatted')

       read(fid) kmax

       allocate( z_s  (kmax) )
       allocate( rho_s(kmax) )
       allocate( tem_s(kmax) )
       allocate( qv_s (kmax) )

       read(fid) z_s  (:)
       read(fid) rho_s(:)
       read(fid) tem_s(:)
       read(fid) qv_s (:)
    close(fid)

    !--- initialization
    do k = ADM_kmin, ADM_kmax
    do kk = 1, kmax-1
       if (       z_s(kk)   <= GRD_gz(k) &
            .AND. z_s(kk+1) >= GRD_gz(k) ) then
          if ( kk == 1 ) then
             kp = 2
          else
             kp = kk
          endif

          rho_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),rho_s(kp+1),z_s(kp),rho_s(kp),z_s(kp-1),rho_s(kp-1))
          tem_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),tem_s(kp+1),z_s(kp),tem_s(kp),z_s(kp-1),tem_s(kp-1))
          qv_ref (k) = lag_intpl(GRD_gz(k),z_s(kp+1),qv_s (kp+1),z_s(kp),qv_s (kp),z_s(kp-1),qv_s (kp-1))
          exit
       endif
    enddo
    enddo

    k  = ADM_kmin-1
    kp = 2

    rho_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),rho_s(kp+1),z_s(kp),rho_s(kp),z_s(kp-1),rho_s(kp-1))
    tem_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),tem_s(kp+1),z_s(kp),tem_s(kp),z_s(kp-1),tem_s(kp-1))
    qv_ref (k) = lag_intpl(GRD_gz(k),z_s(kp+1),qv_s (kp+1),z_s(kp),qv_s (kp),z_s(kp-1),qv_s (kp-1))

    k  = ADM_kmax+1
    kp = kmax-1

    rho_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),rho_s(kp+1),z_s(kp),rho_s(kp),z_s(kp-1),rho_s(kp-1))
    tem_ref(k) = lag_intpl(GRD_gz(k),z_s(kp+1),tem_s(kp+1),z_s(kp),tem_s(kp),z_s(kp-1),tem_s(kp-1))
    qv_ref (k) = lag_intpl(GRD_gz(k),z_s(kp+1),qv_s (kp+1),z_s(kp),qv_s (kp),z_s(kp-1),qv_s (kp-1))

    deallocate( rho_s )
    deallocate( tem_s )
    deallocate( qv_s  )

    return
  end subroutine ooyama_reference

  !-----------------------------------------------------------------------------
  !> generation of basic state from reference state
  subroutine set_basicstate
    use scale_const, only: &
       CONST_GRAV
    use mod_adm, only: &
       ADM_have_pl, &
       ADM_lall,    &
       ADM_lall_pl, &
       ADM_gall,    &
       ADM_gall_pl, &
       ADM_kall
    use mod_grd, only: &
       GRD_Z,     &
       GRD_vz,    &
       GRD_vz_pl
    use mod_vintrpl, only: &
       VINTRPL_zstar_level
    use mod_bndcnd, only: &
       bndcnd_thermo
    use mod_thrmdyn, only: &
       THRMDYN_qd,  &
       THRMDYN_rho, &
       THRMDYN_th
    use mod_runconf, only: &
       TRC_VMAX, &
       I_QV
    implicit none

    real(RP) :: q_bs    (ADM_gall   ,ADM_kall,ADM_lall   ,TRC_VMAX)
    real(RP) :: q_bs_pl (ADM_gall_pl,ADM_kall,ADM_lall_pl,TRC_VMAX)
    real(RP) :: qd_bs   (ADM_gall   ,ADM_kall,ADM_lall   )
    real(RP) :: qd_bs_pl(ADM_gall_pl,ADM_kall,ADM_lall_pl)

    integer :: k, l
    !---------------------------------------------------------------------------

    !--- calculation of geo-potential
    phi(:,:,:) = CONST_GRAV * GRD_vz(:,:,:,GRD_Z)
    if ( ADM_have_pl ) then
       phi_pl(:,:,:) = CONST_GRAV * GRD_vz_pl(:,:,:,GRD_Z)
    endif

    if( ref_type == 'NOBASE' ) return

    do l = 1, ADM_lall
    do k = 1, ADM_kall
       pre_bs(:,k,l) = pre_ref(k)
       tem_bs(:,k,l) = tem_ref(k)
       qv_bs (:,k,l) = qv_ref (k)
    enddo
    enddo

    if ( ADM_have_pl ) then
       do l = 1, ADM_lall_pl
       do k = 1, ADM_kall
          pre_bs_pl(:,k,l) = pre_ref(k)
          tem_bs_pl(:,k,l) = tem_ref(k)
          qv_bs_pl (:,k,l) = qv_ref (k)
       enddo
       enddo
    endif

    !-- from z-level to zstar-level
    call VINTRPL_zstar_level( pre_bs, pre_bs_pl, .false. )
    call VINTRPL_zstar_level( tem_bs, tem_bs_pl, .false. )
    call VINTRPL_zstar_level( qv_bs,  qv_bs_pl,  .false. )

    !--- Setting of mass concentration [Note] The basic state is "dry" and TKE=0
    q_bs(:,:,:,:)    = 0.0_RP
    q_bs(:,:,:,I_QV) = qv_bs(:,:,:)

    call THRMDYN_qd( ADM_gall,       & ! [IN]
                     ADM_kall,       & ! [IN]
                     ADM_lall,       & ! [IN]
                     q_bs (:,:,:,:), & ! [IN]
                     qd_bs(:,:,:)    ) ! [OUT]

    call THRMDYN_rho( ADM_gall,        & ! [IN]
                      ADM_kall,        & ! [IN]
                      ADM_lall,        & ! [IN]
                      tem_bs(:,:,:),   & ! [IN]
                      pre_bs(:,:,:),   & ! [IN]
                      qd_bs (:,:,:),   & ! [IN]
                      q_bs  (:,:,:,:), & ! [IN]
                      rho_bs(:,:,:)    ) ! [OUT]

    !--- set boundary conditions of basic state
    do l = 1, ADM_lall
       call bndcnd_thermo( ADM_gall,      & ! [IN]
                           tem_bs(:,:,l), & ! [INOUT]
                           rho_bs(:,:,l), & ! [INOUT]
                           pre_bs(:,:,l), & ! [INOUT]
                           phi   (:,:,l)  ) ! [IN]
    enddo

    call THRMDYN_th( ADM_gall,      & ! [IN]
                     ADM_kall,      & ! [IN]
                     ADM_lall,      & ! [IN]
                     tem_bs(:,:,:), & ! [IN]
                     pre_bs(:,:,:), & ! [IN]
                     th_bs (:,:,:)  ) ! [OUT]

    if ( ADM_have_pl ) then
       q_bs_pl(:,:,:,:)    = 0.0_RP
       q_bs_pl(:,:,:,I_QV) = qv_bs_pl(:,:,:)

       call THRMDYN_qd( ADM_gall_pl,       & ! [IN]
                        ADM_kall,          & ! [IN]
                        ADM_lall_pl,       & ! [IN]
                        q_bs_pl (:,:,:,:), & ! [IN]
                        qd_bs_pl(:,:,:)    ) ! [OUT]

       call THRMDYN_rho( ADM_gall_pl,        & ! [IN]
                         ADM_kall,           & ! [IN]
                         ADM_lall_pl,        & ! [IN]
                         tem_bs_pl(:,:,:),   & ! [IN]
                         pre_bs_pl(:,:,:),   & ! [IN]
                         qd_bs_pl (:,:,:),   & ! [IN]
                         q_bs_pl  (:,:,:,:), & ! [IN]
                         rho_bs_pl(:,:,:)    ) ! [OUT]

       do l = 1, ADM_lall_pl
          call bndcnd_thermo( ADM_gall_pl,      & ! [IN]
                              tem_bs_pl(:,:,l), & ! [INOUT]
                              rho_bs_pl(:,:,l), & ! [INOUT]
                              pre_bs_pl(:,:,l), & ! [INOUT]
                              phi_pl   (:,:,l)  ) ! [IN]
       enddo

       call THRMDYN_th( ADM_gall_pl,      & ! [IN]
                        ADM_kall,         & ! [IN]
                        ADM_lall_pl,      & ! [IN]
                        tem_bs_pl(:,:,:), & ! [IN]
                        pre_bs_pl(:,:,:), & ! [IN]
                        th_bs_pl (:,:,:)  ) ! [OUT]
    endif

    return
  end subroutine set_basicstate

  !-----------------------------------------------------------------------------
  subroutine bsstate_output_ref( basename )
    use mod_adm, only: &
       ADM_prc_me,     &
       ADM_prc_run_master
    implicit none

    Character(*), Intent(in) :: basename
    integer :: fid

    !--- output
    if ( ADM_prc_me==ADM_prc_run_master) then
       fid = IO_get_available_fid()
       Open(fid,file=Trim(basename),form='unformatted')
       Write(fid) pre_ref(:)
       Write(fid) tem_ref(:)
       Write(fid) qv_ref(:)
       Close(fid)
       !
    endif

    return
  end subroutine bsstate_output_ref

  !-----------------------------------------------------------------------------
  subroutine bsstate_input_ref( basename )
    use scale_const, only: &
         CONST_GRAV,  &
         CONST_Rdry,  &
         CONST_Rvap,  &
         CONST_CPdry, &
         CONST_PRE00
    use mod_adm, only :  &
         ADM_kall
    use mod_grd, only :  &
         GRD_gz
    implicit none

    Character(*), Intent(in) :: basename
    integer :: fid

    real(RP) :: kappa
    integer :: k

    kappa = CONST_Rdry / CONST_CPdry

    !--- input
    fid = IO_get_available_fid()
    Open(fid,file=Trim(basename),status='old',form='unformatted')
    read(fid) pre_ref(:)
    read(fid) tem_ref(:)
    read(fid) qv_ref(:)
    Close(fid)
    !
    !--- additional reference state.
    do k = 1, ADM_kall
       th_ref(k)                                        &
            = tem_ref(k)                                &
            * ( CONST_PRE00 / pre_ref(k) )**kappa
       phi_ref(k) = CONST_GRAV * GRD_gz(k)
       rho_ref(k) = pre_ref(k)/ ( (1.0_RP-qv_ref(k))*CONST_Rdry+qv_ref(k)*CONST_Rvap )/ tem_ref(k)
    enddo

  end subroutine bsstate_input_ref

end module mod_bsstate


      subroutine cornl (lxi1,lx1,lyj1,ly1,k1,m1,k2,m2,
     *x,y,a,lxx,lyy,xf1,yf1,rmax,rmin)
C...subroutine cornl   01/09/78
      common /gfvp/ v1,v2,v3,xr,yr,infin
       common /gfkj/ kj,n
       common /gfxy/ xf,yf,r1,xlast,ylast
      common /gfl/ l,l1,n5,i,ldedg,ldgj,jj,lyj
      common /gfb/ ibx,byi,kk,nob,lllx,xlsi,ylsi
      common /gftab/ irdb(5),rdb(17)
      dimension rmax(1),rmin(1)
       dimension x(lxx),y(lyy),xf1(1),yf1(lxx),a(lxx,lyy)
      fis(xf)=r1* (xf - rdb(7)) + 1.5
C
       lxi=lxi1
       lx=lx1
       lyj=lyj1+1
       ly=ly1
             lllx=lxx
       if(kj.lt.0)    go to 15
       do 135 m=1,n
      rmax(m)=0.
  135 rmin(m)=1.
15     continue
C
C                         ,,leading edges,,
      ldedg=0
         ldgj=0
      kk=1
       lxl=lxx+lxx
             jbg=0
       do 100 i1=lxx,lxl
  100        xf1(i1)=0.
C   ---------------------------------------------------  - ------------
      do 80 k=1,3
      if(m1.ge.2)    go to 22
      go to (50,51,52),k
 50   jj=lxi+1
      go to  20
 51   jj=lxi
      go to   20
C
C
 22   go to (60,61,52),k
 60   jj=lx-1
      go to   20
 61   jj=lx
      go to   20
  52  if(m2.ge.2)  goto 54
      jj=lyj
      go to   25
 54   jj=ly-1
      go to   25
C
C        this is leading left edge
C
  20  call map (x(jj),y(k1),a(jj,k1))
             if(infin.le.0)   go to 101
             xf1(lxx+jj)=1.
             go to   80
  101        jbg=jbg+1
      call tmf(xr,yr,xf,yf)
      xf1(jj) = xf
      yf1(jj) = yf
         ixf=fis (xf)
      yfi = yf
             if(jbg.gt.1)   go to 76
  75  ibx = ixf
      byi = yfi
      call move (xf,yf,0)
      xlast=xf
      ylast=yf
      call patch(xf1,yf1,rmax,rmin)
      go to 80
76    call patch(xf1,yf1,rmax,rmin)
      ibx = ixf
      byi = yfi
      xlast=xf
      ylast=yf
      go to   80
C
C     this is leading front edge
  25  call map(x(k2),y(jj),a(k2,jj))
             if(infin.gt.0)   go to 80
              jbg=jbg+1
              xf1(lxx+k2)=0.
              call tmf(xr,yr,xf,yf)
              if(jbg.gt.1)   go to 108
              xf1(k2)=xf
              yf1(k2)=yf
              go to   75
  108         continue
         ixf=fis(xf)
      yfi = yf
      call patch(xf1,yf1,rmax,rmin)
      ibx = ixf
      byi = yfi
       xf1(k2)=xf
       yf1(k2)=yf
      xlast=xf
      ylast=yf
   80 continue
      lxi=lxi+1
             jcol=1
C  jcol=1---means there is not yet xlstj,ylstj.
             if(infin.gt.0)   go to  111
             jcol=0
      xlstj=xf
      ylstj=yf
  111        continue
      ldedg=0
      ldgj=0
      kk=0
C   ---------------------------------------------------  - ------------
C                            ,,patches,,
      do 155 jj=lyj,ly
      j=jj
      if(m2.ge.2)     j=ly-jj+lyj-1
C
  35  call map (x(k2),y(j),a(k2,j))
             irow=0
             if(infin.le.0)   go to 120
  121        irow=1
C   irow=1 --- means that a pen is absent yet in this matem. row.
             go to   123
  120        call tmf(xr,yr,xf,yf)
             if(jcol.le.0)   go to 124
             jcol=0
             xlstj=xf
             ylstj=yf
  124        continue
      ibx=fis(xlstj)
      byi=ylstj
      xlast=xlstj
      ylast=ylstj
      if(jj.le.lyj)   go to 27
      call move (xlstj,ylstj,0)
      ldgj=-1
      call patch(xf1,yf1,rmax,rmin)
      ldgj=0
 27   xlstj=xf
      ylstj=yf
      xf1(k2) = xf
      yf1(k2) = yf
       xlast = xf
       ylast = yf
  123        continue
C
              nob=0
C
      do 155 ii =lxi,lx
      if(jj.gt.lyj)   go to 43
      if(ii-lxi)   43,48,42
 42   i=ii
      if(m1.ge.2)    i=lx-ii+lxi-1
 45   call map (x(i),y(k1),a(i,k1))
             if(infin.le.0)   go to 131
             xf1(lxx+i)=1.
             ibx=fis(xlsi)
             byi=ylsi
             call move(xlsi,ylsi,0)
             xlast=xlsi
             ylast=ylsi
              nob=0
             go to   40
  131  call tmf(xr,yr,xf,yf)
             if(nob.le.0)   go to 133
             ixf=fis(xf)
             yfi=yf
             ibx=ixf
             byi=yfi
             xlast=xf
             ylast=yf
             call move(xf,yf,0)
              nob=0
  133        continue
      ldedg=-1
      call patch(xf1,yf1,rmax,rmin)
      ldedg=0
      go to   40
48    ldedg=1
 43   go to (36,37),m1
  36  i=ii
      go to 40
  37  i=lx-ii+lxi-1
C
  40  call map(x(i),y(j),a(i,j))
             if(infin.le.0)   go to 141
             if(jj.ne.lyj)   go to 155
      if(xf1(lxx+i).gt.0.)   goto 147
             ibx=fis(xf1(i))
             byi=yf1(i)
             xlast=xf1(i)
             ylast=yf1(i)
             go to   155
  147        nob=1
             go to   155
  141        continue
      call tmf (xr,yr,xf,yf)
             if(irow.le.0)   go to 143
             irow=0
             call move(xf,yf,0)
             ixf=fis(xf)
             yfi=yf
             ibx=ixf
             byi=yfi
             xlast=xf
             ylast=yf
  143        continue
      call patch(xf1,yf1,rmax,rmin)
      ldedg=0
155   continue
      return
      end


MODULE IRVISsnowCoeff_Module

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE Type_Kinds               , ONLY: dp=>Double
  USE File_Utility             , ONLY: Get_Lun, File_Exists
  USE Message_Handler          , ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, &
                                       Display_Message
  USE Spectral_Units_Conversion, ONLY: micron_to_inverse_cm
  USE SEcategory_Define        , ONLY: SEcategory_type      , &
                                       OPERATOR(==)          , &
                                       SEcategory_Associated, &
                                       SEcategory_Create    , &
                                       SEcategory_Destroy   , &
                                       SEcategory_WriteFile , &
                                       SEcategory_ReadFile
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ----------
  ! Visibility
  ! ----------
  PRIVATE
  PUBLIC :: IRVISsnowCoeff_CreateFile

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  CHARACTER(*), PARAMETER :: SURFACE_TYPE_NAME = 'snow'
  CHARACTER(*), PARAMETER :: MODULE_NAME = 'IRVIS'//SURFACE_TYPE_NAME//'Coeff_Module'
  INTEGER , PARAMETER :: ML = 256
  REAL(dp), PARAMETER :: IR_CUTOFF_WAVELENGTH  = 3.0_dp
  REAL(dp), PARAMETER :: VIS_CUTOFF_WAVELENGTH = 4.0_dp

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                           ## PUBLIC PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

  SUBROUTINE IRVISsnowCoeff_CreateFile(visible)
    LOGICAL, OPTIONAL, INTENT(IN) :: visible
    ! Local variables
    TYPE(SEcategory_type) :: npoess

    ! Fill structures with data
    CALL Load_NPOESS_Data(npoess, Visible=visible)

    ! Write data to file
    CALL Write_File(npoess, Visible=visible)

    ! Cleanup
    CALL SEcategory_Destroy( npoess )

  END SUBROUTINE IRVISsnowCoeff_CreateFile

!################################################################################
!################################################################################
!##                                                                            ##
!##                          ## PRIVATE PROCEDURES ##                          ##
!##                                                                            ##
!################################################################################
!################################################################################

  SUBROUTINE Write_File(sec, visible)
    TYPE(SEcategory_type), INTENT(IN) :: sec
    LOGICAL,     OPTIONAL, INTENT(IN) :: visible
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Write_File'
    ! Local variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: sensor_type_name, filename_suffix
    INTEGER :: err_stat
    LOGICAL :: infrared
    TYPE(SEcategory_type) :: sec_copy

    ! Setup
    infrared = .TRUE.
    IF ( PRESENT(Visible) ) infrared = .NOT. Visible
    IF ( infrared ) THEN
      sensor_type_name = 'IR'
    ELSE
      sensor_type_name = 'VIS'
    END IF
    filename_suffix  = '.'//TRIM(sensor_type_name)//SURFACE_TYPE_NAME//'.EmisCoeff.bin'

    ! Write data to file
    err_stat = SEcategory_WriteFile( &
                 sec, &
                 TRIM(sec%Classification_Name)//TRIM(filename_suffix), &
                 Title = TRIM(sensor_type_name)//' '//&
                         TRIM(sec%Classification_Name)//' Surface Reflectances', &
                 History = MODULE_VERSION_ID, &
                 Comment = 'Data extracted from CRTM_surface_ir_emissivity module.' )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error writing '//TRIM(sec%Classification_Name)//' data to file.'
      CALL Display_Message( MODULE_NAME//','//ROUTINE_NAME, msg, FAILURE ); STOP
    END IF

    ! Read data from file
    err_stat = SEcategory_ReadFile( &
                 sec_copy, &
                 TRIM(sec%Classification_Name)//TRIM(filename_suffix) )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading '//TRIM(sec%Classification_Name)//' data from file.'
      CALL Display_Message( MODULE_NAME//','//ROUTINE_NAME, msg, FAILURE ); STOP
    END IF

    ! Check that structures are equal
    IF ( sec == sec_copy ) THEN
      msg = TRIM(sec%Classification_Name)//' structure read from file is the same!'
    ELSE
      msg = TRIM(sec%Classification_Name)//' structure read from file is different!'
    END IF
    CALL Display_Message( MODULE_NAME//','//ROUTINE_NAME, msg, INFORMATION )

    ! Clean up
    CALL SEcategory_Destroy( sec_copy )

  END SUBROUTINE Write_File

  SUBROUTINE Load_NPOESS_Data(npoess, visible)
    TYPE(SEcategory_type), INTENT(OUT) :: npoess
    LOGICAL,     OPTIONAL, INTENT(IN)  :: visible
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Load_NPOESS_Data'
    ! ...The surface type indices
    INTEGER, PARAMETER :: INVALID = 0
    INTEGER, PARAMETER :: OLD_SNOW   = 1
    INTEGER, PARAMETER :: FRESH_SNOW = 2
    ! ...The surface types
    INTEGER     , PARAMETER :: N_SURFACE_TYPES = 2
    CHARACTER(*), PARAMETER :: SURFACE_TYPE(N_SURFACE_TYPES) = &
     (/ 'old_snow  ', &
        'fresh_snow' /)
    ! ...The spectral dimension
    INTEGER , PARAMETER :: N_WAVELENGTHS = 74
    REAL(dp), PARAMETER :: WAVELENGTH(N_WAVELENGTHS) = &
      (/ 0.200_dp, 0.225_dp, 0.250_dp, 0.275_dp, 0.300_dp, 0.325_dp, 0.350_dp, 0.375_dp, &
         0.400_dp, 0.425_dp, 0.450_dp, 0.475_dp, 0.500_dp, 0.525_dp, 0.550_dp, 0.575_dp, &
         0.600_dp, 0.625_dp, 0.650_dp, 0.675_dp, 0.700_dp, 0.725_dp, 0.750_dp, 0.775_dp, &
         0.800_dp, 0.825_dp, 0.850_dp, 0.875_dp, 0.900_dp, 0.925_dp, 0.950_dp, 0.975_dp, &
         1.000_dp, 1.050_dp, 1.100_dp, 1.150_dp, 1.200_dp, 1.250_dp, 1.300_dp, 1.350_dp, &
         1.400_dp, 1.450_dp, 1.500_dp, 1.550_dp, 1.600_dp, 1.650_dp, 1.700_dp, 1.750_dp, &
         1.800_dp, 1.850_dp, 1.900_dp, 1.950_dp, 2.000_dp, 2.500_dp, 3.000_dp, 3.500_dp, &
         4.000_dp, 4.500_dp, 5.000_dp, 5.500_dp, 6.000_dp, 6.500_dp, 7.000_dp, 7.500_dp, &
         8.000_dp, 8.500_dp, 9.000_dp, 9.500_dp,10.000_dp,11.000_dp,12.000_dp,13.000_dp, &
        14.000_dp,15.000_dp /)
    ! ...The reflectance data
    REAL(dp) :: reflectance(N_WAVELENGTHS, N_SURFACE_TYPES)
    INTEGER :: i
    ! ...old snow
    DATA (reflectance(i,OLD_SNOW),i=1,N_WAVELENGTHS)/ &
      0.882_dp,0.892_dp,0.903_dp,0.913_dp,0.924_dp,0.934_dp,0.946_dp,0.955_dp, &
      0.958_dp,0.959_dp,0.954_dp,0.951_dp,0.944_dp,0.940_dp,0.930_dp,0.917_dp, &
      0.908_dp,0.900_dp,0.889_dp,0.876_dp,0.856_dp,0.833_dp,0.807_dp,0.779_dp, &
      0.754_dp,0.727_dp,0.677_dp,0.642_dp,0.583_dp,0.537_dp,0.473_dp,0.419_dp, &
      0.351_dp,0.367_dp,0.360_dp,0.287_dp,0.164_dp,0.124_dp,0.132_dp,0.125_dp, &
      0.094_dp,0.021_dp,0.002_dp,0.000_dp,0.000_dp,0.000_dp,0.008_dp,0.009_dp, &
      0.015_dp,0.037_dp,0.025_dp,0.025_dp,0.000_dp,0.000_dp,0.031_dp,0.013_dp, &
      0.015_dp,0.010_dp,0.014_dp,0.010_dp,0.008_dp,0.009_dp,0.009_dp,0.009_dp, &
      0.009_dp,0.009_dp,0.008_dp,0.008_dp,0.006_dp,0.010_dp,0.018_dp,0.020_dp, &
      0.025_dp,0.020_dp/
    ! ...fresh snow
    DATA (reflectance(i,FRESH_SNOW),i=1,N_WAVELENGTHS)/ &
      0.961_dp,0.964_dp,0.966_dp,0.969_dp,0.972_dp,0.974_dp,0.977_dp,0.979_dp, &
      0.979_dp,0.979_dp,0.979_dp,0.979_dp,0.979_dp,0.977_dp,0.977_dp,0.974_dp, &
      0.972_dp,0.970_dp,0.969_dp,0.969_dp,0.964_dp,0.960_dp,0.953_dp,0.946_dp, &
      0.937_dp,0.923_dp,0.912_dp,0.893_dp,0.874_dp,0.858_dp,0.840_dp,0.813_dp, &
      0.790_dp,0.779_dp,0.786_dp,0.758_dp,0.654_dp,0.611_dp,0.612_dp,0.607_dp, &
      0.516_dp,0.291_dp,0.145_dp,0.115_dp,0.158_dp,0.183_dp,0.251_dp,0.291_dp, &
      0.306_dp,0.425_dp,0.150_dp,0.070_dp,0.044_dp,0.092_dp,0.031_dp,0.013_dp, &
      0.023_dp,0.009_dp,0.015_dp,0.008_dp,0.007_dp,0.008_dp,0.008_dp,0.009_dp, &
      0.008_dp,0.009_dp,0.006_dp,0.006_dp,0.005_dp,0.008_dp,0.018_dp,0.020_dp, &
      0.025_dp,0.020_dp/
    ! Local variables
    CHARACTER(ML) :: msg
    LOGICAL :: infrared
    INTEGER :: n, n_points
    INTEGER, ALLOCATABLE :: idx(:)

    ! Setup
    infrared = .TRUE.
    IF ( PRESENT(Visible) ) infrared = .NOT. Visible

    ! Select indices for spectral region
    IF ( infrared ) THEN
      n_points = COUNT(WAVELENGTH >= IR_CUTOFF_WAVELENGTH)
      ALLOCATE(idx(n_points))
      idx = PACK((/(i,i=1,N_WAVELENGTHS)/),WAVELENGTH >= IR_CUTOFF_WAVELENGTH)
    ELSE
      n_points = COUNT(WAVELENGTH <= VIS_CUTOFF_WAVELENGTH)
      ALLOCATE(idx(n_points))
      idx = PACK((/(i,i=1,N_WAVELENGTHS)/),WAVELENGTH <= VIS_CUTOFF_WAVELENGTH)
    END IF
    ! ...Reverse the index array so the frequencies are in ascending
    ! ...order when the wavelength units are converted.
    idx = idx(n_points:1:-1)

    ! Create structure
    CALL SEcategory_Create( &
           npoess, &
           n_Frequencies   = n_points, &
           n_Surface_Types = N_SURFACE_TYPES )
    IF ( .NOT. SEcategory_Associated(npoess) ) THEN
      msg = 'Error creating NPOESS SEcategory structure'
      CALL Display_Message( MODULE_NAME//','//ROUTINE_NAME, msg, FAILURE ); STOP
    END IF

    ! Assign the classification type and spectral ordinate
    npoess%Classification_Name = 'NPOESS'
    npoess%Frequency = micron_to_inverse_cm(WAVELENGTH(idx))

    ! Assign the data to the structure
    npoess%Surface_Type = SURFACE_TYPE
    DO n = 1, N_SURFACE_TYPES
      npoess%Reflectance(:,n) = reflectance(idx,n)
    END DO

    ! Clean up
    DEALLOCATE(idx)

  END SUBROUTINE Load_NPOESS_Data

END MODULE IRVISsnowCoeff_Module


      SUBROUTINE MBDPDH (AJJL,F,DF,F1,DF1,F2,DF2,XWTE,YWTE,PAREA,CAPPHI,
     1                   DPHITE,DSS,Q,Q1,Q2,NDN,ND1,NW1,NWN,KTE,KTE1,
     2                   KTE2,NTE,NNCB,NNSBD,IN17,IBUF,A)
C
      LOGICAL        CNTRL2,CNTRL1,CRANK1,CRANK2,ASYM,SURF,LPHI,TEBOX
      DIMENSION      F(1),DF(1),F1(1),DF1(1),F2(1),DF2(1),XWTE(1),
     1               YWTE(1),PAREA(50,50,3),NDN(1),ND1(1),NW1(1),NWN(1),
     2               KTE(1),KTE1(1),KTE2(1),NTE(1),IBUF(1)
      COMPLEX        CAPPHI(1),DPHITE(3,NNSBD),DSS(NNCB,NNSBD),DPHI,TDH,
     1               WS,WF1,WF2,TEMPHI,WPHI,SUMPHI,TRAILE,Q(1),Q1(1),
     2               Q2(1),A(1)
      COMMON /MBOXA/ X(12),Y(12),TANG(10),ANG(10),COTANG(10)
      COMMON /MBOXC/ NJJ ,CRANK1,CRANK2,CNTRL1,CNTRL2,NBOX,NPTS0,NPTS1,
     1               NPTS2,ASYM,GC,CR,MACH,BETA,EK,EKBAR,EKM,BOXL,BOXW,
     2               BOXA ,NCB,NSB,NSBD,NTOTE,KC,KC1,KC2,KCT,KC1T,KC2T
      DATA    NHCONT,NHDSS /4HCONT,4HDSS /
C
      NSKP   = 0
      N1     = NPTS0 + NPTS1
      CALL GOPEN (IN17,IBUF,0)
      DO 4000 MOOD = 1,NJJ
      DO 110 I = 1,NSBD
      NTE(I) = 0
      DPHITE(1,I) = (0.0, 0.0)
      DPHITE(2,I) = (0.0, 0.0)
      DPHITE(3,I) = (0.0, 0.0)
  110 CONTINUE
      DO 120 I = 1,NCB
      DO 120 J = 1,NSBD
      DSS(I,J) = (0.0, 0.0)
  120 CONTINUE
      DO 121 J = 1,KCT
      Q (J)  = (0.0, 0.0)
      F(J)   = 0.0
  121 DF(J)  = 0.0
      IF (.NOT.CNTRL1) GO TO 116
      DO 115 J = 1,KC1T
      Q1(J)  = (0.0, 0.0)
      F1(J)  = 0.0
      DF1(J) = 0.0
  115 CONTINUE
  116 IF (.NOT.CNTRL2) GO TO 118
      DO 117 J = 1,KC2T
      Q2(J)  = (0.0, 0.0)
      F2(J)  = 0.0
      DF2(J) = 0.0
  117 CONTINUE
  118 CALL FREAD (IN17,Z,-NSKP,0)
      JJ = MOOD
      IF (JJ .GT. NPTS0) GO TO 140
      CALL FREAD (IN17,F,KCT,0)
      CALL FREAD (IN17,DF,KCT,0)
      NSKP = NSKP + 2*KCT
      GO TO 160
  140 IF (JJ .GT. N1) GO TO 150
      CALL FREAD (IN17,F1 ,KC1T,0)
      CALL FREAD (IN17,DF1,KC1T,0)
      NSKP = NSKP + KC1T*2
      GO TO 160
  150 CALL FREAD (IN17,F2 ,KC2T,0)
      CALL FREAD (IN17,DF2,KC2T,0)
      NSKP = NSKP + KC2T*2
  160 CALL BCKREC (IN17)
C
C     START LOOP FOR ROWS ON PLANFORM
C
      KC  = 0
      KC1 = 0
      KC2 = 0
      DO 3000 I = 1,NCB
      IXR = I - 1
      XB  = BOXL*(FLOAT(IXR) + 0.5)
      XBB = XB + BOXL/2.0
C
C     BOXES ON PLANE OF MAIN
C
      DO 1100 J = 1,NSBD
      IF (.NOT.(I.GE.ND1(J) .AND. I.LE.NDN(J))) GO TO 1100
      DPHI  = (0.0, 0.0)
      WPHI  = DPHI
      TDH   = (0.0 ,0.0)
      LPHI  = .FALSE.
      SURF  = .FALSE.
      TEBOX = .FALSE.
      IF (I .GE. (NW1(J)+NWN(J))/2) TEBOX = .TRUE.
      IYR   = J - 1
      YB    = BOXW*FLOAT(IYR)
      K     = 1
      IF (YB .GT. Y(2)) K = 2
      PAW   = PAREA(I,J,1)
      PAF1  = PAREA(I,J,2)
      PAF2  = PAREA(I,J,3)
      PAWF  = PAW + PAF1 + PAF2
      IF (.NOT.TEBOX .AND. BETA.GT.TANG(K)) PAWF = 1.0
      PAD   = 1.0 - PAWF
      WS    = (0.0, 0.0)
      WF1   = (0.0, 0.0)
      WF2   = (0.0, 0.0)
      IF (J.EQ.1 .AND. ASYM) GO TO  800
      IF (J .GT. NSB) GO TO 500
      IF (PAD .GE. 0.995) GO TO  400
      IF (PAW .LT. 0.005) GO TO  200
C
      KC = KC + 1
      WS = 2.0*PAW*CMPLX(DF(KC), EK*F(KC))
C
  200 IF (PAF1 .LT. 0.005) GO TO  250
C
      KC1 = KC1 + 1
      WF1 = 2.0*PAF1*CMPLX(DF1(KC1), EK*F1(KC1))
C
  250 IF (PAF2 .LT. 0.005) GO TO 300
C
      KC2 = KC2 + 1
      WF2 = 2.0*PAF2*CMPLX(DF2(KC2), EK*F2(KC2))
C
  300 TDH    = (WS+WF1+WF2)/(PAWF*CR)
      LPHI   = .TRUE.
      TEMPHI = SUMPHI(IXR,IYR,ND1,NDN,CAPPHI,DSS,NNCB,NNSBD,ASYM)
      DPHI   = TDH*CAPPHI(1) + TEMPHI
      IF (PAWF .GE. .005) SURF = .TRUE.
      IF (.NOT.SURF .OR. .NOT.TEBOX) GO TO 350
      NTE(J) =  I
      DPHITE(3,J) = DPHITE(2,J)
      DPHITE(2,J) = DPHITE(1,J)
      DPHITE(1,J) = DPHI
C
  350 IF (PAWF .GT. 0.995) GO TO  800
  400 IF (.NOT.TEBOX) GO TO 500
      XT = XWTE(J)
      IF (XT .GE. XBB) GO TO 420
      DPHITE(1,J) = TRAILE(XT,J,NTE,DPHITE,NNSBD,BOXL)
      IF (XT .LE. XB) GO TO 450
  420 IF (XT .GE. XBB+BOXL) GO TO 500
      WPHI = DPHI
      GO TO 800
  450 EX   = EK*(XB-XT)/BOXL
      WPHI = DPHITE(1,J)*CMPLX(COS(EX), -SIN(EX))
      GO TO 800
  500 DPHI = PAWF*DPHI
      WPHI = (0.0, 0.0)
      IF (.NOT.LPHI) TEMPHI = SUMPHI(IXR,IYR,ND1,NDN,CAPPHI,DSS,NNCB,
     1                               NNSBD,ASYM)
      TDH  = PAD*(WPHI-TEMPHI)/CAPPHI(1) + PAWF*TDH
      IF (.NOT.SURF) DPHI = WPHI
  800 IF (SURF) CALL MBGAW (BOXL,DPHI,WS,PAW,PAF1,PAF2,Q,Q1,Q2,J,KC,KC1,
     1                      KC2)
C
      DSS(I,J) = TDH
 1100 CONTINUE
 3000 CONTINUE
      CALL MBGATE (NTOTE,DPHITE,NNSBD,YWTE,Q,Q1,Q2,KTE,KTE1,KTE2)
      CALL MBGAE (AJJL,IN17,A,F,DF,F1,DF1,F2,DF2,Q,Q1,Q2,MOOD)
      CALL BUG (NHCONT,3000,NJJ,30)
      CALL BUG (NHDSS ,3000,DSS,4)
 4000 CONTINUE
      CALL CLOSE (IN17,1)
      RETURN
      END


MODULE ps_init_mol_module

  use ps_local_mol_module, only: init_ps_local_mol, construct_ps_local_mol
  use ps_pcc_mol_module, only: init_ps_pcc_mol, construct_ps_pcc_mol
  use ps_initrho_mol_module, only: init_ps_initrho_mol,construct_ps_initrho_mol
  use ps_nloc2_init_module, only: ps_nloc2_init
  use ps_nloc2_mol_module, only: prep_ps_nloc2_mol

  implicit none

  PRIVATE
  PUBLIC ps_init_mol

CONTAINS

  SUBROUTINE ps_init_mol( Gcut, rho )
    implicit none
    real(8),intent(IN) :: Gcut
    real(8),intent(INOUT) :: rho(:,:)

    call init_ps_local_mol(Gcut)
    call init_ps_pcc_mol
    call init_ps_initrho_mol

    !call Construct_RgridMol(Igrid)

    call construct_ps_local_mol
    call construct_ps_pcc_mol
    call construct_ps_initrho_mol( rho )
    !call normalize_density

    call ps_nloc2_init(Gcut)
    call prep_ps_nloc2_mol

    !call ConstructBoundary_RgridMol(Md,Igrid)

  END SUBROUTINE ps_init_mol

END MODULE ps_init_mol_module