!
!***********************************************************************
!
      module Coupling_transform_cfg_LScLSJ3
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      use Coupling_constants
      use Coupling_structures
      use Coupling_data
      use Coupling_inside_shell
!-----------------------------------------------
!   R o u t i n e s
!-----------------------------------------------
      public  :: main_cfg_lsclsJ3
      public  :: count_nr_of_csfs_cLSJ3
      public  :: delete_cfg_expansions
      private :: form_list_nomach_csfs
      private :: form_csfs_cLSJ3
      private :: matrix_LS_cLSJ3
      private :: dotransform_LScLSJ3
      private :: print_cfg_LScLSJ3
      private :: equivalent_LScLSJ3
!-----------------------------------------------
!   D e f i n i t i o n s
!-----------------------------------------------
      type::Ji_lists
         integer::nr_of_csf !serial number of csf_LS in csfs_LS
         type(list),dimension(:),pointer::Ji !i=1..nr_of_subc
      end type Ji_lists
!
      type:: cfg_Ji_lists
         integer::nr_of_subc
         integer::nr_of_nomach_csfs
         type(Ji_lists),dimension(:),pointer::csfs_Ji !i=1..nr_of_nomach_csfs
      end type cfg_Ji_lists
!
      type(expansion), public :: expansion_cfg_LS
      type(expansion), public :: expansion_cfg_cLSJ3
!
      type(list), private ::nomach_csfs_ls
      type(cfg_Ji_lists), private::cfg_Ji_structure
!-----------------------------------------------
!
contains
!
!***********************************************************************
!                                                                      *
      subroutine main_cfg_lsclsJ3(print_level)
!                                                                      *
!     This is managerial subroutine                                    *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: print_level
      integer::error
      integer::itype
      expansion_cfg_cLSJ3%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=0
      call form_csfs_cLSJ3(itype)
      call dotransform_LScLSJ3
      if(print_level.gt.1) call print_cfg_LScLSJ3(2)
      deallocate(nomach_csfs_ls%items, STAT = error)
      end subroutine main_cfg_lsclsJ3
!
!***********************************************************************
!                                                                      *
      subroutine count_nr_of_csfs_cLSJ3(nr_of_csfs)
!                                                                      *
!     This subroutine counts the number of oneconfigurational          *
!     expansion in cLSJ3 coupling                                      *
!     (corresponding to the one in the JJ coupling "expansion_cfg_LS") *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(out):: nr_of_csfs
      integer::error
      integer::itype
      if(expansion_cfg_LS%csfs(1)%nosubc /= 3) then
         write(*,*)                                                    &
            'ERROR at subroutine count_nr_of_csfs_cLSJ3: nosubc /= 3'
         write(*,*)                                                    &
            '(you can use cLSJ3 coupling with subshells number  = 3)'
         write(*,*) 'At presint number of subshells is',               &
            expansion_cfg_LS%csfs(1)%nosubc
         write(*,*)'program is terminated'
         stop
      end if
      expansion_cfg_cLSJ3%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=1
      call form_csfs_cLSJ3(itype)
      nr_of_csfs = expansion_cfg_cLSJ3%size
      if(associated(nomach_csfs_ls%items))                             &
                             deallocate(nomach_csfs_ls%items,STAT=error)
      end subroutine count_nr_of_csfs_cLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine delete_cfg_expansions
!                                                                      *
!     This subroutine deallocates the arrays of                        *
!     oneconfigurational expansions "expansion_cfg_cLSJ3" and          *
!     "expansion_cfg_LS"                                               *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      integer::icsf
!
!write(iwrite_log,'(6x,a21)') 'delete_cfg_expansions'
!
!delete expansion_cfg_cLSJ3
      if(associated(expansion_cfg_cLSJ3%coeffs))                       &
                                    deallocate(expansion_cfg_cLSJ3%csfs)
      if(associated(expansion_cfg_cLSJ3%csfs)) then
         do icsf=1, expansion_cfg_cLSJ3%size
            if(associated(expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg))    &
                     deallocate(expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_cLSJ3%csfs(icsf)%subc))        &
                         deallocate(expansion_cfg_cLSJ3%csfs(icsf)%subc)
            if(associated(expansion_cfg_cLSJ3%csfs(icsf)%iM1))         &
                          deallocate(expansion_cfg_cLSJ3%csfs(icsf)%iM1)
            if(associated(expansion_cfg_cLSJ3%csfs(icsf)%iM2))         &
                          deallocate(expansion_cfg_cLSJ3%csfs(icsf)%iM2)
            if(associated(expansion_cfg_cLSJ3%csfs(icsf)%iJ))          &
                          deallocate(expansion_cfg_cLSJ3%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_cLSJ3%csfs)
      end if
      expansion_cfg_cLSJ3%size=0
      expansion_cfg_cLSJ3%nr_of_state=0
!
!delete expansion_cfg_LS
      if(associated(expansion_cfg_LS%coeffs))                          &
                                       deallocate(expansion_cfg_LS%csfs)
      if(associated(expansion_cfg_LS%csfs)) then
         do icsf=1, expansion_cfg_LS%size
            if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg))       &
                        deallocate(expansion_cfg_LS%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_LS%csfs(icsf)%subc))           &
                            deallocate(expansion_cfg_LS%csfs(icsf)%subc)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM1))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM1)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM2))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM2)
            if(associated(expansion_cfg_LS%csfs(icsf)%iJ))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_LS%csfs)
      end if
      expansion_cfg_LS%size=0
      expansion_cfg_LS%nr_of_state=0
!
      end subroutine delete_cfg_expansions
!
!***********************************************************************
!                                                                      *
      function equivalent_LScLSJ3(csf1, csf2)               result(rez)
!                                                                      *
!     This function defines the "equivalency" of                       *
!     two csfs in LS coupling for the formation of cLSJ3 csfs          *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      type(csf_LS) :: csf1, csf2
      logical :: rez
      integer::isubc
      rez = .true.
      if(csf1%nosubc /= 3 .or. csf2%nosubc /= 3) then
         write(*,*)'ERROR at subroutine equivalent_LScLSJ3: ',         &
                   'csf1%nosubc /= 3 .or. csf2%nosubc /= 3'
         write(*,*)'(you can use cLSJ3 coupling with shell number 3)'
         write(*,*)'program will be terminated'
         write(*,*)'csf1%nosubc, csf2%nosubc',csf1%nosubc, csf2%nosubc
         stop
      end if
      if(csf1%nosubc.eq.csf2%nosubc) then
         do isubc=1,csf1%nosubc
            if(.not.csf1%subc_cfg(isubc)==csf2%subc_cfg(isubc)) then
               rez=.false.
               exit
            else if(.not.csf1%subc(isubc)==csf2%subc(isubc)) then
               if(isubc /= 1) rez=.false.
               exit
            end if
         end do
      else
         rez=.false.
      end if
      end function equivalent_LScLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine form_list_nomach_csfs
!                                                                      *
!     This subroutine form the list of serial numbers                  *
!     in "expansion_cfg_LS" of "nonequivalent" LS coupling csfs        *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer:: inomach_counter
      integer, dimension(:), pointer :: temp_list
      integer::icsf_LS, inew
      logical:: new_csf
!
      inomach_counter=0
      allocate(temp_list(expansion_cfg_LS%size))
!
      do icsf_LS=1,expansion_cfg_LS%size,1
         new_csf = .true.
         do inew = 1, inomach_counter, 1
            if(equivalent_LScLSJ3(expansion_cfg_LS%csfs(icsf_LS),      &
              expansion_cfg_LS%csfs(temp_list(inew)))) new_csf = .false.
         end do
         if(new_csf) then
            inomach_counter = inomach_counter + 1
            if(inomach_counter.gt.expansion_cfg_LS%size) then
               write(*,*) 'stop at subroutine define_nomach: ',        &
                  'inomach_counter.gt.expansion_cfg_LS%size'
               stop
            end if
            temp_list(inomach_counter)= icsf_LS
         end if
      end do
!
      nomach_csfs_LS%list_size = inomach_counter
!
      allocate(nomach_csfs_LS%items(nomach_csfs_LS%list_size))
!
      do icsf_LS=1, nomach_csfs_LS%list_size, 1
         nomach_csfs_LS%items(icsf_LS) = temp_list(icsf_LS)
      end do
!
      deallocate(temp_list)
!----- print down data -----------
!      write(99, *)'Nonmaching csfs_LS:'
!      write(99, *)'       Nr.   icsf_nr '
!      do icsf_LS=1, nomach_csfs_LS%list_size, 1
!	 write(99, '(4x,i3,2x,i3)') icsf_LS, nomach_csfs_LS%items(icsf_LS)
!      end do  !icsf_LS
!      write(99, *)'  '
!
      end subroutine form_list_nomach_csfs
!
!***********************************************************************
!                                                                      *
      subroutine form_csfs_cLSJ3(itype)
!                                                                      *
!     This subroutine forms the oneconfigurational                     *
!     expansion in cLSJ3 coupling "expansion_cfg_cLSJ3",               *
!     correponding to the one in LS coupling "expansion_cfg_LS"        *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                last update: February 2020   *
!                                                                      *
!***********************************************************************
      implicit none
!type(cfg_Ji_lists),intent(in)::cfg_Ji_structure
      integer:: itype !defines the type of execution
                      !itype=1 - to find the number
                      !of csfs_cLSJ3 only,
                      !itype.ne.1 - perform full
                      !calculation
!GG!      real(kind=dp) :: coef
      integer :: inr_of_csfs_cLSJ3
      integer :: icsf_LS, icsf_cLSJ3
      integer :: L, L_min, L_max, IS, IS_min, IS_max
      integer :: J_1, J_1_min, J_1_max
      integer :: J_12, J_12_min, J_12_max
      integer :: isubc_aviable, ITTK
      integer :: inosubc, isubc
      integer :: iJ_total, Q_Term, Nr_Term
      integer :: icsf_nr
      integer :: I, N1_MAX, N1_big, N2_big, number_1, number_2
      integer :: I_Count, iterm_1, iterm_2, N1_big_jj, N2_big_jj
      type(subshell_term), dimension(1:63)  :: jj_1_term, jj_2_term
      isubc_aviable = 3
      if(expansion_cfg_LS%csfs(1)%nosubc /= isubc_aviable) then
         write(*,*) "is available =",isubc_aviable," we have =",       &
           expansion_cfg_LS%csfs(1)%nosubc
         write(*,*) 'STOP at subroutine define_number_of_csfs_cLSJ3 ', &
           'module transform_lsclsj3: cfg_Ji_structure%nr_of_subc.gt.',&
           'isubc_aviable'
         stop
      end if
      iJ_total=states%states(expansion_cfg_LS%nr_of_state)%J
      call define_number_of_csfs_cLSJ3(inr_of_csfs_cLSJ3)
      expansion_cfg_cLSJ3%size=inr_of_csfs_cLSJ3
      if(itype.ne.1) then
         allocate(expansion_cfg_cLSJ3%csfs(expansion_cfg_cLSJ3%size))
         allocate(expansion_cfg_cLSJ3%coeffs(expansion_cfg_cLSJ3%size))
         icsf_cLSJ3=0
         do icsf_LS=1, nomach_csfs_ls%list_size,1
           icsf_nr = nomach_csfs_ls%items(icsf_LS)
           if(expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il == 3 .and. &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big>=3) then
             Nr_Term = expansion_cfg_LS%csfs(icsf_nr)%subc(1)%inr
             Q_Term = gettermLSQ(                                      &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il,            &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big,Nr_term,&
             expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iL,                &
             expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iS)
           else
             Q_Term =                                                  &
                    2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il+1- &
                    expansion_cfg_LS%csfs(icsf_nr)%subc(1)%inr
             Nr_Term = 0
           end if
           inosubc = expansion_cfg_LS%csfs(icsf_nr)%nosubc
           N1_MAX=2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il
           if (N1_MAX == 0) then
              N1_big = 0
              N2_big = expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big
              I_Count = 1
           else if(expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big   &
                                                        <= N1_MAX) then
              N1_big = expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big
              N2_big= 0
              I_Count = N1_big + 1
           else
              N1_big=N1_MAX
              N2_big=                                                  &
                expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big-N1_big
              I_Count=                                                 &
                2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il+2      &
                -N2_big+1
           end if
           L_min = iabs(                                               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL)
           L_max =                                                     &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL
           IS_min = iabs(                                              &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS)
           IS_max =                                                    &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS
           do L = L_min, L_max, 2
              do IS = IS_min, IS_max, 2
                 J_12_min = iabs(L - IS)
                 J_12_max = L + IS
                 do J_12 = J_12_min, J_12_max, 2
                    J_1_min = iabs(J_12 - iJ_total)
                    J_1_max = J_12 + iJ_total
                    do J_1 = J_1_min, J_1_max, 2
                       do I = 1,I_Count,1
                          if (N1_big-I+1 .ge. 0) then
                             if(icsf_cLSJ3.gt.expansion_cfg_cLSJ3%size) then
                               write(*,*)                           &
                              'stop at subroutine form_csfs_cLSJ3:',&
                               ' icsf_nr.gt.expansion_cfg_cLSJ3%size'
                               write(*,*)                           &
                               'J_1,icsf_cLSJ3', J_1,icsf_cLSJ3,    &
                               'expansion_cfg_cLSJ3%size',          &
                               expansion_cfg_cLSJ3%size
                               stop
                             end if
                            if(I == 1) then
                               if (N1_MAX /= 0) then
                                 N1_big_jj = N1_big
                                 call gettermjj                     &
                                 (2*expansion_cfg_LS%csfs(icsf_nr)% &
                                 subc_cfg(1)%il-1,N1_big_jj,        &
                                 jj_1_term,number_1)
                              else
                                 N1_big_jj = 0
                                 number_1 = 1
                                 jj_1_term(1)%j = 0
                                 jj_1_term(1)%Q = 0
                                 jj_1_term(1)%subshellJ = 0
                               end if
                               N2_big_jj = N2_big
                               call gettermjj                       &
                               (2*expansion_cfg_LS%csfs(icsf_nr)%   &
                               subc_cfg(1)%il+1,N2_big_jj,jj_2_term,&
                               number_2)
                             else
                               N1_big_jj = N1_big-I+1
                               N2_big_jj = N2_big+I-1
                               call gettermjj                       &
                               (2*expansion_cfg_LS%csfs(icsf_nr)%   &
                               subc_cfg(1)%il-1,N1_big_jj,jj_1_term,&
                               number_1)
                               call gettermjj                       &
                               (2*expansion_cfg_LS%csfs(icsf_nr)%   &
                               subc_cfg(1)%il+1,N2_big_jj,jj_2_term,&
                               number_2)
                             end if
                             do iterm_1 = 1,number_1
                             do iterm_2 = 1,number_2
                               if(ITTK(2*jj_1_term(iterm_1)%subshellJ, &
                               2*jj_2_term(iterm_2)%subshellJ,         &
                               2*J_1) == 0) cycle
!GG!                     coef = coefLSjj(                                  &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il,    &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big,&
!GG!                     Nr_Term,                                          &
!GG!                     Q_Term,                                           &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iL,        &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iS,        &
!GG!                     J_1,                                              &
!GG!                     jj_1_term(iterm_1)%j,                             &
!GG!                     N1_big_jj,                                        &
!GG!                     jj_1_term(iterm_1)%Q,                             &
!GG!                     jj_1_term(iterm_1)%subshellJ,                     &
!GG!                     jj_2_term(iterm_2)%j,                             &
!GG!                     jj_2_term(iterm_2)%Q,                             &
!GG!                     jj_2_term(iterm_2)%subshellJ)
!GG!                                if (coef == ZERO_dp) cycle
                                icsf_cLSJ3 = icsf_cLSJ3 + 1
                                expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%nosubc= &
                                                                inosubc
                                allocate(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                subc_cfg(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                nosubc))
                                allocate(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                subc(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                nosubc))
                                allocate(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                iM1(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)% &
                                                               nosubc))
                                allocate(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                iM2(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)% &
                                                                nosubc))
                                allocate(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                iJ(expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%nosubc))
                                do isubc=1,expansion_cfg_cLSJ3%csfs(       &
                                                    icsf_cLSJ3)%nosubc,1
                                   expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%  &
                                   subc_cfg(isubc) = expansion_cfg_LS%csfs(&
                                   icsf_nr)%subc_cfg(isubc)
                                   expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%  &
                                   subc(isubc) = expansion_cfg_LS%csfs(    &
                                   icsf_nr)%subc(isubc)
                                   if(isubc == 1) then
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                     iM1(1) = N1_big_jj
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                     iM2(1) = N2_big_jj
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                                         iJ(1)=J_1
                                   else if(isubc == 2) then
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                                         iM1(2)=L
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                                        iM2(2)=IS
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                                        iJ(2)=J_12
                                  else if(isubc == 3) then
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                     iM1(3) = iterm_1
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                     iM2(3) = iterm_2
                                     expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%&
                                                          iJ(3)=iJ_total
                                  end if
                                end do
                             end do
                          end do
                          end if
                       end do
                    end do
                 end do
              end do
           end do
         end do
!
      end if
!
!write(*,*) '      end subroutine form_csfs_cLSJ3'
!write(iwrite_log,*) '      end subroutine form_csfs_cLSJ3'
!
      contains
!
!***********************************************************************
!                                                                      *
         subroutine  define_number_of_csfs_cLSJ3(irez)
!                                                                      *
!     This subroutine defines the number of csfs in cLSJ3 coupling     *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                last update: February 2020   *
!                                                                      *
!***********************************************************************
         implicit none
         integer, intent(out) :: irez
!GG!         real(kind=dp) :: coef
         integer :: L, L_min, L_max, IS, IS_min, IS_max
         integer :: J_1, J_1_min, J_1_max
         integer :: J_12, J_12_min, J_12_max
         integer :: isubc_aviable
         integer :: icsf, icsf_nr, ITTK
         integer :: I, N1_MAX, N1_big, N2_big, number_1, number_2
         integer :: I_Count, iterm_1, iterm_2, N1_big_jj, N2_big_jj
         integer :: Q_Term, Nr_Term
         type(subshell_term), dimension(1:63)  :: jj_1_term, jj_2_term
         isubc_aviable = 3
         if(expansion_cfg_LS%csfs(1)%nosubc /= isubc_aviable) then
           write(*,*)'STOP at subroutine define_number_of_csfs_cLSJ3 ',&
            'module transform_lsclsJ3:cfg_Ji_structure%nr_of_subc.gt.',&
            'isubc_aviable'
           stop
         end if
         irez=0
         do icsf=1, nomach_csfs_ls%list_size,1
           icsf_nr = nomach_csfs_ls%items(icsf)
           if(expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il == 3 .and. &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big>=3) then
             Nr_Term = expansion_cfg_LS%csfs(icsf_nr)%subc(1)%inr
             Q_Term = gettermLSQ(                                      &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il,            &
             expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big,Nr_term,&
             expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iL,                &
             expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iS)
           else
             Q_Term =                                                  &
                    2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il+1- &
                    expansion_cfg_LS%csfs(icsf_nr)%subc(1)%inr
             Nr_Term = 0
           end if
           N1_MAX=2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il
           if (N1_MAX == 0) then
              N1_big = 0
              N2_big = expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big
              I_Count = 1
           else if(expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big   &
                                                        <= N1_MAX) then
              N1_big = expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big
              N2_big= 0
              I_Count = N1_big + 1
           else
              N1_big=N1_MAX
              N2_big=                                                  &
                expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big-N1_big
              I_Count=                                                 &
                2*expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il+2      &
                -N2_big+1
           end if
           L_min = iabs(                                               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL)
           L_max =                                                     &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL
           IS_min = iabs(                                              &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS)
           IS_max =                                                    &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS
           do L = L_min, L_max, 2
              do IS = IS_min, IS_max, 2
                 J_12_min = iabs(L - IS)
                 J_12_max = L + IS
                 do J_12 = J_12_min, J_12_max, 2
                    J_1_min = iabs(J_12 - iJ_total)
                    J_1_max = J_12 + iJ_total
                    do J_1 = J_1_min, J_1_max, 2
                       do I = 1,I_Count,1
                          if (N1_big-I+1 .ge. 0) then
                             if(I == 1) then
                                if (N1_MAX /= 0) then
                                  N1_big_jj = N1_big
                                  call gettermjj(                      &
                                  2*expansion_cfg_LS%csfs(icsf_nr)%    &
                                  subc_cfg(1)%il-1,N1_big_jj,jj_1_term,&
                                  number_1)
                                else
                                  N1_big_jj = 0
                                  number_1 = 1
                                  jj_1_term(1)%j = 0
                                  jj_1_term(1)%Q = 0
                                  jj_1_term(1)%subshellJ = 0
                                end if
                                N2_big_jj = N2_big
                                call gettermjj(                        &
                                2*expansion_cfg_LS%csfs(icsf_nr)%      &
                                subc_cfg(1)%il+1,N2_big_jj,jj_2_term,  &
                                number_2)
                             else
                                N1_big_jj = N1_big-I+1
                                N2_big_jj = N2_big+I-1
                                call gettermjj(                        &
                                2*expansion_cfg_LS%csfs(icsf_nr)%      &
                                subc_cfg(1)%il-1,N1_big_jj,jj_1_term,  &
                                number_1)
                                call gettermjj(                        &
                                2*expansion_cfg_LS%csfs(icsf_nr)%      &
                                subc_cfg(1)%il+1,N2_big_jj,jj_2_term,  &
                                number_2)
                             end if
                             do iterm_1 = 1,number_1
                               do iterm_2 = 1,number_2
                                 if(ITTK(                              &
                                   2*jj_1_term(iterm_1)%subshellJ,     &
                                   2*jj_2_term(iterm_2)%subshellJ,     &
                                   2*J_1) == 0) cycle
!GG!                     coef = coefLSjj(                                  &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%il,    &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc_cfg(1)%iN_big,&
!GG!                     Nr_Term,                                          &
!GG!                     Q_Term,                                           &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iL,        &
!GG!                     expansion_cfg_LS%csfs(icsf_nr)%subc(1)%iS,        &
!GG!                     J_1,                                              &
!GG!                     jj_1_term(iterm_1)%j,                             &
!GG!                     N1_big_jj,                                        &
!GG!                     jj_1_term(iterm_1)%Q,                             &
!GG!                     jj_1_term(iterm_1)%subshellJ,                     &
!GG!                     jj_2_term(iterm_2)%j,                             &
!GG!                     jj_2_term(iterm_2)%Q,                             &
!GG!                     jj_2_term(iterm_2)%subshellJ)
!GG!                                 if (coef /= ZERO_dp) irez = irez + 1
                                 irez = irez + 1
                               end do
                             end do
                          end if
                       end do
                    end do
                 end do
              end do
           end do
         end do
         end subroutine  define_number_of_csfs_cLSJ3
      end subroutine form_csfs_cLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine matrix_LS_cLSJ3(icsf_LS,icsf_cLSJ3,rez)
!                                                                      *
!     This subroutine calculates the transformation                    *
!     matrix element between two csfs  (in LS and cLSJ3 couplings)     *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                last update: February 2020   *
!                                                                      *
!***********************************************************************
      implicit none
      integer,intent(in) :: icsf_LS, icsf_cLSJ3
      real(kind=dp),intent(out) :: rez
      real(kind=dp) :: rez_1, rez_2
      integer :: L_1, L_12, L_2, L_3, L_23, L
      integer :: IS_1, IS_12, IS_2, IS_3, IS_23, IS
      integer :: J_1, J_12, J
      integer :: nosubc, N1, N2, number_1, number_2, num_1, num_2
      integer :: Q_Term, Nr_Term
      type(subshell_term), dimension(1:63)  :: jj_1_term, jj_2_term
      nosubc=expansion_cfg_LS%csfs(1)%nosubc
      rez = ZERO_dp
      if(equivalent_LScLSJ3(expansion_cfg_LS%csfs(icsf_LS),            &
         expansion_cfg_cLSJ3%csfs(icsf_cLSJ3))) then
         L_1    = expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iL
         L_12   = expansion_cfg_LS%csfs(icsf_LS)%iM1(2)
         L_2    = expansion_cfg_LS%csfs(icsf_LS)%subc(2)%iL
         L_3    = expansion_cfg_LS%csfs(icsf_LS)%subc(3)%iL
         L_23   = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM1(2)
         L      = expansion_cfg_LS%csfs(icsf_LS)%iM1(3)
         IS_1   = expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iS
         IS_12  = expansion_cfg_LS%csfs(icsf_LS)%iM2(2)
         IS_2   = expansion_cfg_LS%csfs(icsf_LS)%subc(2)%iS
         IS_3   = expansion_cfg_LS%csfs(icsf_LS)%subc(3)%iS
         IS_23  = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM2(2)
         IS     = expansion_cfg_LS%csfs(icsf_LS)%iM2(3)
         J_1    = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iJ(1)
         J_12   = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iJ(2)
         J      = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iJ(3)
         N1     = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM1(1)
         N2     = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM2(1)
         number_1 = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM1(3)
         number_2 = expansion_cfg_cLSJ3%csfs(icsf_cLSJ3)%iM2(3)
         if(expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il == 3 .and.   &
             expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%iN_big>=3) then
             Nr_Term = expansion_cfg_LS%csfs(icsf_LS)%subc(1)%inr
             Q_Term = gettermLSQ(                                      &
             expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il,            &
             expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%iN_big,Nr_term,&
             expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iL,                &
             expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iS)
         else
             Q_Term =                                                  &
                    2*expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il+1- &
                    expansion_cfg_LS%csfs(icsf_LS)%subc(1)%inr
             Nr_Term = 0
         end if
         if (expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il /= 0) then
            call gettermjj                                             &
               (2*expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il-1,     &
               N1,jj_1_term, num_1)
         else
            jj_1_term(1)%j = 0
            jj_1_term(1)%Q = 0
            jj_1_term(1)%subshellJ = 0
         end if
         call gettermjj                                                &
            (2*expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il+1,        &
            N2,jj_2_term,num_2)
         rez_1 = coefLSjj(                                         &
                 expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%il,    &
                 expansion_cfg_LS%csfs(icsf_LS)%subc_cfg(1)%iN_big,&
                 Nr_Term,                                          &
                 Q_Term,                                           &
                 expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iL,        &
                 expansion_cfg_LS%csfs(icsf_LS)%subc(1)%iS,        &
                 J_1,                                              &
                 jj_1_term(number_1)%j,                            &
                 N1,                                               &
                 jj_1_term(number_1)%Q,                            &
                 jj_1_term(number_1)%subshellJ,                    &
                 jj_2_term(number_2)%j,                            &
                 jj_2_term(number_2)%Q,                            &
                 jj_2_term(number_2)%subshellJ)
         call cLSJ3PER(L_1,L_12, L_2, L_3, L_23, L,                 &
                       IS_1,IS_12,IS_2,IS_3,IS_23,IS,J_1,J_12,J,rez_2)
            rez = rez_1 * rez_2
      end if
!      print*, "isena is matrix_LS_cLSJ3"
      end subroutine matrix_LS_cLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine dotransform_LScLSJ3
!                                                                      *
!     This subroutine calculates the weights of the                    *
!     expansions in the cLSJ3 coupling                                 *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      real(kind=dp)::coeff_cLSJ3,coeff_LS, melement, sum_of_state
      integer::icsf_LS,icsf_cLSJ3
!
      melement=0.
      sum_of_state = 0.
      do icsf_cLSJ3=1,expansion_cfg_cLSJ3%size
         coeff_cLSJ3 = 0.
         do icsf_LS=1, expansion_cfg_LS%size
            call matrix_LS_cLSJ3(icsf_LS,icsf_cLSJ3,melement)
            coeff_LS=expansion_cfg_LS%coeffs(icsf_LS)
            coeff_cLSJ3 = coeff_cLSJ3 + coeff_LS*melement
         end do
         if((dabs(coeff_cLSJ3)-dp_coeff_precision).gt.ONE_dp) then
         write(*,*)'possible error at subroutine dotransform_LScLSJ3:',&
               ' coeff_cLSJ3=',coeff_cLSJ3
            write(iwrite_log,*)'possible error at subroutine ',        &
               'dotransform_LScLSJ3: coeff_cLSJ3=',coeff_cLSJ3
         end if
         expansion_cfg_cLSJ3%coeffs(icsf_cLSJ3)= coeff_cLSJ3
         sum_of_state = sum_of_state + coeff_cLSJ3*coeff_cLSJ3
      end do
!
      if((sum_of_state-10*dp_coeff_precision).gt.ONE_dp) then
        write(*,*)'possible error at subroutine dotransform_LScLSJ3: ',&
            'sum_of_state=',sum_of_state
         write(iwrite_log,*)'possible error at subroutine ',           &
            'dotransform_LScLSJ3: sum_of_state=',sum_of_state
      end if
!
      end subroutine dotransform_LScLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine print_cfg_LScLSJ3(itype)
!                                                                      *
!     This subroutine prints the oneconfigurational                    *
!     expansions to the unit "iwrite_cfg_expansions_cLSJ3"             *
!     (see module "Coupling_constants")                                *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: itype
      integer             :: icsf, isubc, j
      integer             :: num_1, num_2, number_1, number_2
      character(len=1)    :: CVAL
      character(len=2)    :: LSJVAL
      character(len=4)    :: JVAL
      type(subshell_term), dimension(1:63)  :: jj_1_term, jj_2_term
!
!     LScLSJ3 - Coupling
!
      if(itype.gt.0) then
         write(iwrite_cfg_expansions_cLSJ3,*)  &
         '-------------------------------------'
         write(iwrite_cfg_expansions_cLSJ3,*)  &
         'state Nr.',expansion_cfg_LS%nr_of_state
         write(iwrite_cfg_expansions_cLSJ3,'(3x,a3,a4,a9,3x,f15.8)')   &
         'J =', JVAL(states%states(expansion_cfg_LS%nr_of_state)%J), &
         ' Energy =',states%states(expansion_cfg_LS%nr_of_state)%energy
         write(iwrite_cfg_expansions_cLSJ3,'(3x,a30,i2)')              &
         'expansion size (LS coupling): ', expansion_cfg_LS%size
         write(iwrite_cfg_expansions_cLSJ3,*)''
         if(associated(expansion_cfg_LS%csfs)) then
            do icsf=1,expansion_cfg_LS%size
               if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg)) then
                  if(icsf ==1)write(iwrite_cfg_expansions_cLSJ3,*)     &
                     'csf Nr.'
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_cLSJ3,                &
                     '(1x,i5,3x,i2,a1,"(",i1,")",6x,a6,f10.7)') icsf,  &
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%in,       &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%iN_big,   &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_cLSJ3,                &
                     '(1x,i5,3x,2(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,2),                                           &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_cLSJ3,                &
                     '(1x,i5,3x,3(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,3),                                           &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else
                    STOP &
              'To many coupled shells in Coupling_transform_cfg_LScLSJ3'
                  end if
               else
                  write(iwrite_cfg_expansions_cLSJ3,'(9x,a51)')   &
                  'expansion_cfg_LS%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_LS%csfs(icsf)%subc)  &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM1) &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM2)) then
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_cLSJ3,             &
                     '(13x,i2,a1,i1)')                              &
                     expansion_cfg_LS%csfs(icsf)%subc(1)%iS+1,      &
                     CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(1)%iL),&
                     expansion_cfg_LS%csfs(icsf)%subc(1)%inr
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_cLSJ3,              &
                     '(12x,7(1x,i2,a1,i1))')                         &
                     (expansion_cfg_LS%csfs(icsf)%subc(j)%iS+1,      &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(j)%iL),&
                      expansion_cfg_LS%csfs(icsf)%subc(j)%inr,       &
                      j=1,2),                                        &
                      expansion_cfg_LS%csfs(icsf)%iM2(2)+1,          &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%iM1(2))
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_cLSJ3,               &
                     '(12x,3(1x,i2,a1,i1),3(1x,i2,a1))')              &
                     (expansion_cfg_LS%csfs(icsf)%subc(j)%iS+1,       &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(j)%iL), &
                      expansion_cfg_LS%csfs(icsf)%subc(j)%inr,        &
                      j=1,3),                                         &
                      (expansion_cfg_LS%csfs(icsf)%iM2(j)+1,          &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%iM1(j)),j=2,3)
                  end if
               else
                   write(iwrite_cfg_expansions_cLSJ3,'(9x,a63)') &
       'expansion_cfg_LS%csfs(icsf)%subc (or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_cLSJ3,*)' '
            end do
         else
            write(iwrite_cfg_expansions_cLSJ3,*) &
            'expansion_cfg_LS%csfs NOT associated'
         end if
      end if
!
!     cLSJ3 - Coupling
!
      if(itype.gt.1) then
         write(iwrite_cfg_expansions_cLSJ3,*) &
         '-------------------------------------'
         write(iwrite_cfg_expansions_cLSJ3,*) &
         'state Nr.',expansion_cfg_cLSJ3%nr_of_state
         write(iwrite_cfg_expansions_cLSJ3,'(3x,a3,a4,a9,3x,f15.8)')   &
         'J =', JVAL(states%states(expansion_cfg_cLSJ3%nr_of_state)%J),&
       ' Energy =',states%states(expansion_cfg_cLSJ3%nr_of_state)%energy
         write(iwrite_cfg_expansions_cLSJ3,'(3x,a33,i2)')              &
         'expansion size (cLSJ3 coupling): ', expansion_cfg_cLSJ3%size
         write(iwrite_cfg_expansions_cLSJ3,*)''
         if(associated(expansion_cfg_cLSJ3%csfs)) then
            do icsf=1,expansion_cfg_cLSJ3%size
               if(associated(expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg)) then
!                  if(dabs(expansion_cfg_cLSJ3%coeffs(icsf)) <=          &
!                                              dp_coeff_precision) cycle
                  if (expansion_cfg_cLSJ3%csfs(icsf)%nosubc == 3) then
                     number_1 = expansion_cfg_cLSJ3%csfs(icsf)%iM1(3)
                     number_2 = expansion_cfg_cLSJ3%csfs(icsf)%iM2(3)
                     if(expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%il/=0)&
                                                                   then
                        call gettermjj                                 &
                          (2*expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%il&
                          -1,                                          &
                           expansion_cfg_cLSJ3%csfs(icsf)%iM1(1),      &
                           jj_1_term,num_1)
                     else
                        jj_1_term(number_1)%j = -1
                        jj_1_term(number_1)%subshellJ = 0
                        jj_1_term(number_1)%nu  = 0
                     end if
                     call gettermjj                                    &
                       (2*expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%il+1,&
                        expansion_cfg_cLSJ3%csfs(icsf)%iM2(1),         &
                        jj_2_term,num_2)
                     write(iwrite_cfg_expansions_cLSJ3,                &
                     '(1x,i5,3x,2(i2,a2,"(",i1,")"),2(i2,a1,"(",i1, &
                     ")"),6x,a6,f10.7)')icsf,                          &
                     expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%in,    &
                     LSJVAL(                                           &
                     expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%il,    &
                     jj_1_term(number_1)%j),                           &
                     expansion_cfg_cLSJ3%csfs(icsf)%iM1(1),            &
                     expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%in,    &
                     LSJVAL(                                           &
                     expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(1)%il,    &
                     jj_2_term(number_2)%j),                           &
                     expansion_cfg_cLSJ3%csfs(icsf)%iM2(1),            &
                     (expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(j)%in,   &
                 CVAL(1,expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg(j)%iN_big,&
                     j=2,3),                                           &
                     'coeff:',expansion_cfg_cLSJ3%coeffs(icsf)
                  end if
               else
                  write(iwrite_cfg_expansions_cLSJ3,'(9x,a51)')        &
                'expansion_cfg_cLSJ3%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_cLSJ3%csfs(icsf)%subc)     &
                  .and.associated(expansion_cfg_cLSJ3%csfs(icsf)%iM1) &
                  .and.associated(expansion_cfg_cLSJ3%csfs(icsf)%iM2)) then
                  if (expansion_cfg_cLSJ3%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_cLSJ3,                &
                     '(10x,2(1x,a4,i2)," (",i2,a1,i1,1x,i2,a1,i1,")",  &
                     i2,a1,1x," [",a4,","a4," ]")')                   &
                     JVAL(jj_1_term(number_1)%subshellJ),              &
                     jj_1_term(number_1)%nu,                           &
                     JVAL(jj_2_term(number_2)%subshellJ),              &
                     jj_2_term(number_2)%nu,                           &
                     (expansion_cfg_cLSJ3%csfs(icsf)%subc(j)%iS+1,     &
                     CVAL(2,expansion_cfg_cLSJ3%csfs(icsf)%subc(j)%iL),&
                     expansion_cfg_cLSJ3%csfs(icsf)%subc(j)%inr,       &
                     j=2,3),                                           &
                     expansion_cfg_cLSJ3%csfs(icsf)%iM2(2)+1,          &
                     CVAL(2,expansion_cfg_cLSJ3%csfs(icsf)%iM1(2)),    &
                     JVAL(expansion_cfg_cLSJ3%csfs(icsf)%iJ(1)),       &
                     JVAL(expansion_cfg_cLSJ3%csfs(icsf)%iJ(2))
                  end if
               else
                  write(iwrite_cfg_expansions_cLSJ3,'(9x,a63)')        &
                     'expansion_cfg_cLSJ3%csfs(icsf)%subc (',          &
                     'or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_cLSJ3,*)' '
            end do
         else
            write(iwrite_cfg_expansions_cLSJ3,*) &
            'expansion_cfg_cLSJ3%csfs NOT associated'
         end if
            write(iwrite_cfg_expansions_cLSJ3,*) &
            '-------------------------------------'
      end if
      end subroutine print_cfg_LScLSJ3
!
      end module Coupling_transform_cfg_LScLSJ3


!--------------------------------------------------------------------------------
! Copyright (c) 2018 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_types_regionCharges

IMPLICIT NONE

PRIVATE

   TYPE t_regionCharges

      REAL,    ALLOCATABLE :: sqal(:,:,:)
      REAL,    ALLOCATABLE :: ener(:,:,:)
      REAL,    ALLOCATABLE :: sqlo(:,:,:)
      REAL,    ALLOCATABLE :: enerlo(:,:,:)
      REAL,    ALLOCATABLE :: svac(:,:)
      REAL,    ALLOCATABLE :: pvac(:,:)

      CONTAINS
         PROCEDURE,PASS :: init => regionCharges_init
         PROCEDURE      :: sumBandsVac
   END TYPE t_regionCharges

PUBLIC t_regionCharges

CONTAINS

SUBROUTINE regionCharges_init(thisRegCharges,input,atoms)

   USE m_types_input
   USE m_types_atoms

   IMPLICIT NONE

   CLASS(t_regionCharges), INTENT(INOUT) :: thisRegCharges
   TYPE(t_input),          INTENT(IN)    :: input
   TYPE(t_atoms),          INTENT(IN)    :: atoms

   ALLOCATE(thisRegCharges%sqal(0:3,atoms%ntype,input%jspins))
   ALLOCATE(thisRegCharges%ener(0:3,atoms%ntype,input%jspins))

   ALLOCATE(thisRegCharges%sqlo(atoms%nlod,atoms%ntype,input%jspins))
   ALLOCATE(thisRegCharges%enerlo(atoms%nlod,atoms%ntype,input%jspins))
   ALLOCATE(thisRegCharges%svac(2,input%jspins))
   ALLOCATE(thisRegCharges%pvac(2,input%jspins))

   thisRegCharges%sqal = 0.0
   thisRegCharges%ener = 0.0
   thisRegCharges%sqlo = 0.0
   thisRegCharges%enerlo = 0.0
   thisRegCharges%svac = 0.0
   thisRegCharges%pvac = 0.0

END SUBROUTINE regionCharges_init

SUBROUTINE sumBandsVac(thisRegCharges,vacuum,dos,noccbd,ikpt,jsp_start,jsp_end,eig,we)

  USE m_types_vacuum
  USE m_types_dos

   USE m_types_dos

   IMPLICIT NONE

   CLASS(t_regionCharges), INTENT(INOUT) :: thisRegCharges
   TYPE(t_vacuum),         INTENT(IN)    :: vacuum
   TYPE(t_dos),            INTENT(IN)    :: dos
   INTEGER,                INTENT(IN)    :: noccbd
   INTEGER,                INTENT(IN)    :: ikpt
   INTEGER,                INTENT(IN)    :: jsp_start, jsp_end
   REAL,                   INTENT(IN)    :: eig(noccbd)
   REAL,                   INTENT(IN)    :: we(noccbd)

   INTEGER                               :: ispin, ivac

   ! perform Brillouin zone integration and summation over the bands in order to determine the vacuum energy parameters.
   DO ispin = jsp_start, jsp_end
      DO ivac = 1,vacuum%nvac
         thisRegCharges%pvac(ivac,ispin) = thisRegCharges%pvac(ivac,ispin)+&
            dot_product(eig(:noccbd)*dos%qvac(:noccbd,ivac,ikpt,ispin),we(:noccbd))
         thisRegCharges%svac(ivac,ispin)=thisRegCharges%svac(ivac,ispin)+&
            dot_product(dos%qvac(:noccbd,ivac,ikpt,ispin),we(:noccbd))
      END DO
   END DO

END SUBROUTINE sumBandsVac

END MODULE m_types_regionCharges


MODULE PREP_STMAS4D

  USE PRMTRS_STMAS

  PRIVATE  GTSCALING
  PUBLIC   PREPROCSS, GRDMEMALC, RDINITBGD, PHYSCPSTN

!**************************************************
!COMMENT:
!   THIS MODULE IS USED BY stmas_core.f90 TO DO SOME PREPROCESS.
!   SUBROUTINES:
!      PREPROCSS: CALL SUBROUTINE OF GRDMEMALC TO ALLOCATE MEMORYS TO ANALYSIS FIELD AND CALL GTSCALING TO GET SCALES OF OBSERVATIONS.
!      GRDMEMALC: MEMORY ALLOCATE FOR ANALYSIS FIELDS, BACKGROUND FIELDS AND THE COORDINATES.
!      GTSCALING: GET SCALES OF EACH OBSERVATION.
!      RDINITBGD: GET BACKGROUND FILED ON THE CURRENT LEVEL GRID FROM THE INITIAL BACKGROUND (WITH MAX GRID NUMBER).
!      PHYSCPSTN: CALCULATE PENALTY COEFFICENTS AND MAKE SOME SCALING OF CONTROL VARIABLES AND COORDINATES.
!**************************************************

CONTAINS

SUBROUTINE PREPROCSS
!*************************************************
! DATA PREPROCESS
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
  CALL GRDMEMALC
  CALL GTSCALING
  RETURN
END SUBROUTINE PREPROCSS

SUBROUTINE GRDMEMALC
!*************************************************
! MEMORY ALLOCATE FOR GRD ARRAY
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,T,S,ER
! --------------------
  ALLOCATE(WWW(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4)),STAT=ER)
  IF(ER.NE.0)STOP 'WWW ALLOCATE WRONG'
  ALLOCATE(COR(NUMGRID(1),NUMGRID(2)),STAT=ER)
  IF(ER.NE.0)STOP 'COR ALLOCATE WRONG'
  ALLOCATE(XXX(NUMGRID(1),NUMGRID(2)),STAT=ER)
  IF(ER.NE.0)STOP 'XXX ALLOCATE WRONG'
  ALLOCATE(YYY(NUMGRID(1),NUMGRID(2)),STAT=ER)
  IF(ER.NE.0)STOP 'YYY ALLOCATE WRONG'
  ALLOCATE(DEG(NUMGRID(1),NUMGRID(2)),STAT=ER)
  IF(ER.NE.0)STOP 'DEG ALLOCATE WRONG'
  ALLOCATE(DEN(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4)),STAT=ER)
  IF(ER.NE.0)STOP 'DEN ALLOCATE WRONG'
  IF(IFPCDNT.EQ.0 .OR. IFPCDNT.EQ.2)THEN
    ALLOCATE(ZZZ(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4)),STAT=ER)
    IF(ER.NE.0)STOP 'ZZZ ALLOCATE WRONG'
  ELSEIF(IFPCDNT.EQ.1)THEN
    ALLOCATE(PPP(NUMGRID(3)),STAT=ER)
    IF(ER.NE.0)STOP 'PPP ALLOCATE WRONG'
  ENDIF

! YUANFU ADD NUMSTAT+1 GRDBKGND ARRAY FOR SAVING RADAR REFLECTIVITY GENRERATED LOW BOUND AND UPPER BOUND:
  ALLOCATE(GRDBKGND(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4),NUMSTAT+2),STAT=ER)
  IF(ER.NE.0)STOP 'GRDBKGND ALLOCATE WRONG'
  ALLOCATE(GRDANALS(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4),NUMSTAT),STAT=ER)
  IF(ER.NE.0)STOP 'GRDANALS ALLOCATE WRONG'
  DO T=1,NUMGRID(4)
  DO K=1,NUMGRID(3)
  DO J=1,NUMGRID(2)
  DO I=1,NUMGRID(1)
    DO S=1,NUMSTAT
      GRDANALS(I,J,K,T,S)=0.0D0
      GRDBKGND(I,J,K,T,S)=0.0D0
    ENDDO
  ENDDO
  ENDDO
  ENDDO
  ENDDO
  NUMVARS=NUMGRID(1)*NUMGRID(2)*NUMGRID(3)*NUMGRID(4)*NUMSTAT
  ALLOCATE(GRADINT(NUMGRID(1),NUMGRID(2),NUMGRID(3),NUMGRID(4),NUMSTAT),STAT=ER)
  IF(ER.NE.0)STOP 'GRADINT ALLOCATE WRONG'
  RETURN
END SUBROUTINE GRDMEMALC

SUBROUTINE GTSCALING
!*************************************************
! ALLOCATE OBSERVATION MEMORY AND READ IN DATA AND SCALE
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  REAL ,PARAMETER :: SM=1.0E-5
  INTEGER  :: O,S,ER,UU,VV,WW,NO
!added by shuyuan liu 20101028 for adding the OI OI=OBSERROR(O)**2  OI=1.0/OI
  REAL    ::  OI
! --------------------
  UU=U_CMPNNT
  VV=V_CMPNNT
  WW=W_CMPNNT

!jhui
!NUMSTAT+1
  ALLOCATE(SCL(NUMSTAT+1),STAT=ER)
  IF(ER.NE.0)STOP 'SCL ALLOCATE WRONG'
  DO S=1,NUMSTAT+1
    SCL(S)=0.0D0
  ENDDO

  IF(NALLOBS.EQ.0) RETURN
!!!!!!!!!!!!!!!!!!!!
 O=0
!  DO S=1,NUMSTAT
!    DO NO=1,NOBSTAT(S)
 !     O=O+1
!      SCL(S)=SCL(S)+OBSVALUE(O)*OBSVALUE(O)
!    ENDDO
 ! ENDDO
 ! DO S=NUMSTAT+1,NUMSTAT+2
!    DO NO=1,NOBSTAT(S)
!      O=O+1
!      SCL(UU)=SCL(UU)+OBSVALUE(O)*OBSVALUE(O)
!      SCL(VV)=SCL(VV)+OBSVALUE(O)*OBSVALUE(O)
 !   ENDDO
!  ENDDO
!jhui
 ! DO S=NUMSTAT+3,NUMSTAT+3
 !   DO NO=1,NOBSTAT(S)
 !     O=O+1
 !     SCL(NUMSTAT+1)=SCL(NUMSTAT+1)+OBSVALUE(O)*OBSVALUE(O)
 !   ENDDO
 ! ENDDO
! STATISTIC SCALES OF EACH STATE VARIABLE BASED ON OBSERVATIONS.
!!!!!!!!!!adding the OI  modified by shuyuan liu 20101028
  O=0
  DO S=1,NUMSTAT
    DO NO=1,NOBSTAT(S)
      O=O+1
      OI=OBSERROR(O)*OBSERROR(O)
      OI=1.0/OI
      SCL(S)=SCL(S)+OBSVALUE(O)*OBSVALUE(O)*OI
   ENDDO
  ENDDO
  DO S=NUMSTAT+1,NUMSTAT+2
    DO NO=1,NOBSTAT(S)
      O=O+1
      OI=OBSERROR(O)*OBSERROR(O)
      OI=1.0/OI
      SCL(UU)=SCL(UU)+OBSVALUE(O)*OBSVALUE(O)*OI
      SCL(VV)=SCL(VV)+OBSVALUE(O)*OBSVALUE(O)*OI
    ENDDO
  ENDDO
  DO S=NUMSTAT+3,NUMSTAT+3
    DO NO=1,NOBSTAT(S)
      O=O+1
      OI=OBSERROR(O)*OBSERROR(O)
      OI=1.0/OI
      SCL(NUMSTAT+1)=SCL(NUMSTAT+1)+OBSVALUE(O)*OBSVALUE(O)*OI
    ENDDO
  ENDDO
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  DO S=1,NUMSTAT
    IF(NOBSTAT(S).GT.0 .AND. SCL(S).GE.1E-5) THEN
      IF(S.EQ.UU .OR. S.EQ.VV) THEN
        SCL(S)=SQRT(SCL(S)/(NOBSTAT(S)+NOBSTAT(NUMSTAT+1)+NOBSTAT(NUMSTAT+2)))
      ELSE
        SCL(S)=SQRT(SCL(S)/NOBSTAT(S))
      ENDIF
    ELSEIF(NOBSTAT(S).EQ.0) THEN
      SCL(S)=SL0(S)
    ENDIF
  ENDDO
  IF(NUMDIMS.GE.2)SCL(UU)=MAX(SCL(UU),SCL(VV))
  IF(NUMDIMS.GE.2)SCL(VV)=SCL(UU)
  IF(WW.NE.0)SCL(WW)=SCL(UU)
!jhui
  IF (NOBSTAT(NUMSTAT+3) .GT. 0) THEN  ! YUANFU: AVOID DIVISION OF ZERO
    DO S=NUMSTAT+3,NUMSTAT+3
        SCL(NUMSTAT+1)=SQRT(SCL(NUMSTAT+1)/NOBSTAT(S))
    ENDDO
  ENDIF

! SCALE THE OBSERVATIONS
  O=0
  DO S=1,NUMSTAT
    DO NO=1,NOBSTAT(S)
      O=O+1
      OBSVALUE(O)=OBSVALUE(O)/SCL(S)
      OBSERROR(O)=OBSERROR(O)/SCL(S)
    ENDDO
  ENDDO
  DO S=NUMSTAT+1,NUMSTAT+2
    DO NO=1,NOBSTAT(S)
      O=O+1
      OBSVALUE(O)=OBSVALUE(O)/SCL(UU)
      OBSERROR(O)=OBSERROR(O)/SCL(UU)
    ENDDO
  ENDDO
!jhui
  !DO S=NUMSTAT+3,NUMSTAT+3  !changed by shuyuan 20100903
    S=NUMSTAT+3
    DO NO=1,NOBSTAT(S)
      O=O+1
      OBSVALUE(O)=OBSVALUE(O)/SCL(NUMSTAT+1)
      OBSERROR(O)=OBSERROR(O)/SCL(NUMSTAT+1)
    ENDDO
  !ENDDO

  RETURN
END SUBROUTINE GTSCALING

SUBROUTINE RDINITBGD
!*************************************************
! READ IN INITIAL BACKGROUND FIELDS
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,T,S,NX,NY,NZ,NT,I1,J1,K1,T1,TT
  REAL     :: R
! --------------------
  R=287
  TT=TEMPRTUR

  IF(NUMGRID(1).GE.2)THEN
    NX=(MAXGRID(1)-1)/(NUMGRID(1)-1)
  ELSE
    NX=1
  ENDIF
  IF(NUMGRID(2).GE.2)THEN
    NY=(MAXGRID(2)-1)/(NUMGRID(2)-1)
  ELSE
    NY=1
  ENDIF
  IF(NUMGRID(3).GE.2)THEN
    NZ=(MAXGRID(3)-1)/(NUMGRID(3)-1)
  ELSE
    NZ=1
  ENDIF
  IF(NUMGRID(4).GE.2)THEN
    NT=(MAXGRID(4)-1)/(NUMGRID(4)-1)
  ELSE
    NT=1
  ENDIF
! INTERPLATE THE BACKGROUND FIELD ONTO THE CURRENT ANALYSIS GRID POINTS.
  DO T=1,MAXGRID(4),NT
  DO K=1,MAXGRID(3),NZ
  DO J=1,MAXGRID(2),NY
  DO I=1,MAXGRID(1),NX
    I1=(I-1)/NX+1
    J1=(J-1)/NY+1
    K1=(K-1)/NZ+1
    T1=(T-1)/NT+1
!jhui
    DO S=1,NUMSTAT
      GRDBKGND(I1,J1,K1,T1,S)=GRDBKGD0(I,J,K,T,S)/SCL(S)
    ENDDO
    ! MAKE SURE SH BACKGROUND POSITIVE:
    GRDBKGND(I1,J1,K1,T1,5) = MAX(0.0,GRDBKGND(I1,J1,K1,T1,5))
    ! SH LOWER AND UPPER BOUND AT THE MULTIGRID LEVEL:
    GRDBKGND(I1,J1,K1,T1,NUMSTAT+1)=GRDBKGD0(I,J,K,T,NUMSTAT+1)/SCL(HUMIDITY)
    GRDBKGND(I1,J1,K1,T1,NUMSTAT+2)=GRDBKGD0(I,J,K,T,NUMSTAT+2)/SCL(HUMIDITY)
     IF(IFPCDNT.NE.1) DEN(I1,J1,K1,T1)=DN0(I,J,K,T)     ! here the pressure is not aviable
     IF(IFPCDNT.EQ.1) DEN(I1,J1,K1,T1)=(PPP(K1)*SCP(PSL)+ORIVTCL)/R/((GRDBKGND(I1,J1,K1,T1,TT)+GRDANALS(I1,J1,K1,T1,TT))*SCL(TT))
  ENDDO
  ENDDO
  ENDDO
  ENDDO

  RETURN
END SUBROUTINE RDINITBGD

SUBROUTINE PHYSCPSTN
!*************************************************
! DEALING WITH PHYSICAL POSITION AND PENALTY COEFFICENT AND MAKING SOME SCALING
! HISTORY: AUGUST 2007, CODED by WEI LI.
!*************************************************
  IMPLICIT NONE
! --------------------
  INTEGER  :: I,J,K,T,S,NX,NY,NZ,NT,I1,J1,K1,T1,UU,VV,PP
  REAL     :: Z1,Z2
! --------------------
  UU=U_CMPNNT
  VV=V_CMPNNT
  PP=PRESSURE
! PHYSICAL POSITION AND CORIOLIS FREQUENCY
  IF(NUMGRID(1).GE.2)THEN
    NX=(MAXGRID(1)-1)/(NUMGRID(1)-1)
  ELSE
    NX=1
  ENDIF
  IF(NUMGRID(2).GE.2)THEN
    NY=(MAXGRID(2)-1)/(NUMGRID(2)-1)
  ELSE
    NY=1
  ENDIF
  DO J=1,MAXGRID(2),NY
  DO I=1,MAXGRID(1),NX
    I1=(I-1)/NX+1
    J1=(J-1)/NY+1
    IF(NUMGRID(1).GE.2)XXX(I1,J1)=XX0(I,J)
    IF(NUMGRID(2).GE.2)YYY(I1,J1)=YY0(I,J)
    IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)COR(I1,J1)=CR0(I,J)
    IF(NUMGRID(2).GE.2)DEG(I1,J1)=DG0(I,J)
  ENDDO
  ENDDO

  IF(NUMGRID(3).GE.2)THEN
    NZ=(MAXGRID(3)-1)/(NUMGRID(3)-1)
  ELSE
    NZ=1
  ENDIF
  IF(NUMGRID(4).GE.2)THEN
    NT=(MAXGRID(4)-1)/(NUMGRID(4)-1)
  ELSE
    NT=1
  ENDIF

  IF(IFPCDNT.EQ.0 .OR. IFPCDNT.EQ.2)THEN          ! FOR SIGMA AND HEIGHTCOORDINATE
    DO T=1,MAXGRID(4),NT
    DO K=1,MAXGRID(3),NZ
    DO J=1,MAXGRID(2),NY
    DO I=1,MAXGRID(1),NX
      I1=(I-1)/NX+1
      J1=(J-1)/NY+1
      K1=(K-1)/NZ+1
      T1=(T-1)/NT+1
      ZZZ(I1,J1,K1,T1)=ZZ0(I,J,K,T)
    ENDDO
    ENDDO
    ENDDO
    ENDDO
  ELSEIF(IFPCDNT.EQ.1)THEN
    DO K=1,MAXGRID(3),NZ
      K1=(K-1)/NZ+1
      PPP(K1)=PP0(K)
    ENDDO
  ENDIF

! PENALTY COEFFICENT
  DO S=1,NUMSTAT
    PENAL_X(S) = 0.0
    PENAL_Y(S) = 0.0
    PENAL_Z(S) = 0.0
    PENAL_T(S) = 0.0
    IF(NUMGRID(1).GE.3) PENAL_X(S)=PENAL0X(S)*((MAXGRID(1)-2)*MAXGRID(2)*MAXGRID(3)*MAXGRID(4))  &
                                   /((NUMGRID(1)-2)*NUMGRID(2)*NUMGRID(3)*NUMGRID(4))
    IF(NUMGRID(2).GE.3) PENAL_Y(S)=PENAL0Y(S)*((MAXGRID(2)-2)*MAXGRID(1)*MAXGRID(3)*MAXGRID(4))  &
                                   /((NUMGRID(2)-2)*NUMGRID(1)*NUMGRID(3)*NUMGRID(4))
    IF(NUMGRID(3).GE.3) PENAL_Z(S)=PENAL0Z(S)*((MAXGRID(3)-2)*MAXGRID(1)*MAXGRID(2)*MAXGRID(4))  &
                                   /((NUMGRID(3)-2)*NUMGRID(1)*NUMGRID(2)*NUMGRID(4))
    IF(NUMGRID(4).GE.3) PENAL_T(S)=PENAL0T(S)*((MAXGRID(4)-2)*MAXGRID(1)*MAXGRID(2)*MAXGRID(3))  &
                                   /((NUMGRID(4)-2)*NUMGRID(1)*NUMGRID(2)*NUMGRID(3))
  ENDDO
  !  PENAL_X(NUMSTAT+1) = PENAL_X(1)
  !  PENAL_Y(NUMSTAT+1) = PENAL_Y(1)
  !  PENAL_Z(NUMSTAT+1) = PENAL_Z(1)
  !  PENAL_T(NUMSTAT+1) = PENAL_T(1)

  PNLT_PU=PNLT0PU*SCL(UU)*SCL(UU)/(2**(GRDLEVL-1)) &
              /(NUMGRID(1)*NUMGRID(2)*NUMGRID(3)*NUMGRID(4))
  PNLT_PV=PNLT0PV*SCL(VV)*SCL(VV)/(2**(GRDLEVL-1)) &
              /(NUMGRID(1)*NUMGRID(2)*NUMGRID(3)*NUMGRID(4))
  IF(NALLOBS.NE.0) THEN
    IF(NOBSTAT(UU).EQ.0.AND.NOBSTAT(PP).EQ.0)PNLT_PU=0.0D0
    IF(NOBSTAT(VV).EQ.0.AND.NOBSTAT(PP).EQ.0)PNLT_PV=0.0D0
  ENDIF

  PNLT_HY=PNLT0HY*TAUL_HY**(GRDLEVL-1)  &
              /(NUMGRID(1)*NUMGRID(2)*NUMGRID(3)*NUMGRID(4))

! CALCULATE SCALE FOR PHYSICAL POSITION AND CORIOLIS FREQUENCY
  SCP(XSL)=ABS((XXX(NUMGRID(1),NUMGRID(2))-XXX(1,1))/(NUMGRID(1)-1))
  SCP(YSL)=ABS((YYY(NUMGRID(1),NUMGRID(2))-YYY(1,1))/(NUMGRID(2)-1))
  IF(IFPCDNT.EQ.0 .OR. IFPCDNT.EQ.2)THEN         ! FOR SIGMA AND HEIGHTCOORDINATE
    Z2=ZZZ(1,1,NUMGRID(3),1)
    Z1=ZZZ(1,1,1,1)
    DO I=1,NUMGRID(1)
    DO J=1,NUMGRID(2)
    DO T=1,NUMGRID(4)
      Z2=MAX(Z2,ZZZ(I,J,NUMGRID(3),T))
      Z1=MIN(Z1,ZZZ(I,J,1,T))
    ENDDO
    ENDDO
    ENDDO
    SCP(PSL)=ABS((Z2-Z1)/(NUMGRID(3)-1))
  ELSEIF(IFPCDNT.EQ.1)THEN
    SCP(PSL)=ABS((PPP(NUMGRID(3))-PPP(1))/(NUMGRID(3)-1))
  ENDIF
  IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)SCP(CSL)=ABS(COR(1,1))
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)SCP(CSL)=MAX(SCP(CSL),ABS(COR(I,J)))
  ENDDO
  ENDDO
  IF (SCP(CSL) .LT. 1.0e-5) SCP(CSL) = 1.0 ! Temporarily turn off scaling Coroilis
  IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)SCP(DSL)=ABS(DEN(1,1,1,1))
  DO T=1,NUMGRID(4)
  DO K=1,NUMGRID(3)
  DO J=1,NUMGRID(2)
  DO I=1,NUMGRID(1)
    IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)SCP(DSL)=MAX(SCP(DSL),ABS(DEN(I,J,K,T)))
  ENDDO
  ENDDO
  ENDDO
  ENDDO
  IF (SCP(DSL) .LT. 1.0e-5) SCP(DSL) = 1.0 ! Temporarily turn off scaling Geostrophic with density
! SCALE THE PHYSICAL POSITION AND CORIOLIS FREQUENCY
  DO I=1,NUMGRID(1)
  DO J=1,NUMGRID(2)
    IF(NUMGRID(1).GE.2)XXX(I,J)=(XXX(I,J)-ORIPSTN(1))/SCP(XSL)
    IF(NUMGRID(2).GE.2)YYY(I,J)=(YYY(I,J)-ORIPSTN(2))/SCP(YSL)
    IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)COR(I,J)=COR(I,J)/SCP(CSL)
  ENDDO
  ENDDO
  DO T=1,NUMGRID(4)
  DO K=1,NUMGRID(3)
  DO J=1,NUMGRID(2)
  DO I=1,NUMGRID(1)
    IF(PNLT0PU.GE.1.0E-10.OR.PNLT0PV.GE.1.0E-10)DEN(I,J,K,T)=DEN(I,J,K,T)/SCP(DSL)
  ENDDO
  ENDDO
  ENDDO
  ENDDO
  IF(IFPCDNT.EQ.0 .OR. IFPCDNT.EQ.2)THEN         ! FOR SIGMA AND HEIGHT COORDINATE
    ORIVTCL=ZZZ(1,1,1,1)
    DO T=1,NUMGRID(4)
    DO K=1,NUMGRID(3)
    DO J=1,NUMGRID(2)
    DO I=1,NUMGRID(1)
      ZZZ(I,J,K,T)=(ZZZ(I,J,K,T)-ORIVTCL)/SCP(PSL)
    ENDDO
    ENDDO
    ENDDO
    ENDDO
  ELSEIF(IFPCDNT.EQ.1)THEN                       ! FOR PRESSURE COORDINATE
    ORIVTCL=PPP(1)
    DO K=1,NUMGRID(3)
      PPP(K)=(PPP(K)-ORIVTCL)/SCP(PSL)
    ENDDO
  ENDIF

  RETURN
END SUBROUTINE PHYSCPSTN

END MODULE PREP_STMAS4D


!> Module containing definition of abstract base class AbstractSoilLayer
module AbstractSoilLayerModule
    use Globals                                                     ! Global definitions and constants
    use mo_netcdf                                                   ! NetCDF input/output
    use ResultModule, only: Result                                  ! Result object to pass errors
    use BiotaSoilModule
    implicit none

    !> Abstract base class for \1 object. Defines properties and
    !! methods required in any implementation of a \1 class. The
    !! `SoilLayer` class routes water and ultimately nanoparticles through
    !! a layer of soil.
    type, abstract, public :: AbstractSoilLayer
        ! Setup, dimensions and metadata
        character(len=256)      :: ref                                  !! Reference name for this `SoilLayer`
        integer                 :: x                                    !! Containing `GridCell` x index
        integer                 :: y                                    !! Containing `GridCell` y index
        integer                 :: p                                    !! Containing `SoilProfile` index
        integer                 :: l                                    !! Layer index
        real(dp)                :: depth                                !! Layer depth [m]
        real(dp)                :: area                                 !! Area of the containing SoilProfile [m2]
        real(dp)                :: volume                               !! Volume of the soil layer [m3]
        ! Nanomaterials
        real(dp), allocatable   :: m_np(:,:,:)                          !! Mass of NM currently in layer [kg]
        real(dp), allocatable   :: m_np_perc(:,:,:)                     !! Mass of NM percolating to layer below on given timestep [kg]
        real(dp), allocatable   :: m_np_eroded(:,:,:)                   !! Mass of NM eroded on given timestep [kg]
        real(dp), allocatable   :: C_np(:,:,:)                          !! Mass concentration of NM [kg/kg soil]
        real(dp), allocatable   :: m_transformed(:,:,:)
        real(dp), allocatable   :: m_transformed_perc(:,:,:)
        real(dp), allocatable   :: m_transformed_eroded(:,:,:)
        real(dp), allocatable   :: C_transformed(:,:,:)
        real(dp), allocatable   :: m_dissolved
        real(dp), allocatable   :: m_dissolved_perc
        real(dp), allocatable   :: m_dissolved_eroded
        real(dp), allocatable   :: C_dissolved
        ! Hydrology
        real(dp)                :: q_in                                 !! Inflow to this `SoilLayer` [m3 m-2 s-1]
        real(dp)                :: V_w                                  !! Volume of water currently in layer [m3 m-2]
        real(dp)                :: V_pool                               !! Volume of water above `V_sat` to be pooled into layer above [m3 m-2]
        real(dp)                :: V_excess                             !! Volume of water above `V_FC` that can percolate to the next layer [m3 m-2]
        real(dp)                :: V_perc                               !! Volume of water percolating to next layer on a given time step [m3 m-2]
        real(dp)                :: V_sat                                !! Water content at saturation [m3 m-2]
        real(dp)                :: V_FC                                 !! Water content at field capacity [m3 m-2]
        real(dp)                :: K_s                                  !! Saturated hydraulic conductivity [m s-1]
        real(dp)                :: bulkDensity                          !! Bulk density [kg m-3]
        real(dp)                :: d_grain                              !! Average grain diameter [m]
        real(dp)                :: porosity                             !! Porosity [-]
        real(dp)                :: earthwormDensity                     !! Earthworm density [individuals/layer]
        ! NM transformations
        real                    :: alpha_att                            !! Attachment efficiency to soil matrix [-]
        real, allocatable       :: k_att(:)                             !! Attachment rate to soil matrix [s-1]
        ! Biota
        integer                 :: nBiota = 0
        integer, allocatable    :: biotaIndices(:)
        class(BiotaSoil), allocatable :: biota(:)
      contains
        procedure(createAbstractSoilLayer), deferred :: create
        procedure(updateAbstractSoilLayer), deferred :: update
        procedure(addPooledWaterAbstractSoilLayer), deferred :: addPooledWater
        procedure(erodeAbstractSoilLayer), deferred :: erode
        procedure(parseInputDataAbstractSoilLayer), deferred :: parseInputData
        procedure(calculateBioturbationRateAbstractSoilLayer), deferred :: calculateBioturbationRate
        ! Non-deferred procedures
        procedure :: setV_pool
    end type

    !> Container type for `class(AbstractSoilLayer)` such that a polymorphic
    !! AbstractSoilLayer class can be stored in `SoilLayerElement%item`.
    type SoilLayerElement
        class(AbstractSoilLayer), allocatable :: item
            !! Polymorphic AbstractSoilLayer object, which can contain any type that extends AbstractSoilLayer
    end type

    abstract interface
        !> Create this AbstractSoilLayer
        function createAbstractSoilLayer(me, x, y, p, l, WC_sat, WC_FC, K_s, area, &
            bulkDensity, d_grain, porosity, earthwormDensity) result(r)
            use Globals, only: dp
            use ResultModule, only: Result
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me                  !! This AbstractSoilLayer instance
            integer, intent(in) :: x                        !! Containing `GridCell` x index
            integer, intent(in) :: y                        !! Containing `GridCell` y index
            integer, intent(in) :: p                        !! Containing `SoilProfile` index
            integer, intent(in) :: l                        !! Layer index
            real(dp), intent(in) :: WC_sat                  !! Water content at saturation [m3/m3]
            real(dp), intent(in) :: WC_FC                   !! Water content at field capacity [m3/m3]
            real(dp), intent(in) :: K_s                     !! Saturated hydraulic conductivity [m/s]
            real(dp), intent(in) :: area                    !! Area of the containing SoilProfile [m2]
            real(dp), intent(in) :: bulkDensity             !! Bulk density [kg/m3]
            real(dp), intent(in) :: d_grain                 !! Average grain diameter [m]
            real(dp), intent(in) :: porosity                !! Porosity [-]
            real(dp), intent(in) :: earthwormDensity        !! Earthworm density [individuals/layer]
            type(Result) :: r                               !! The `Result` object to return
        end function

        !> Update the AbstractSoilLayer on a given timestep
        function updateAbstractSoilLayer(me, t, q_in, m_np_in, m_transformed_in, m_dissolved_in) result(r)
            use ResultModule, only: Result
            use Globals, only: dp
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me                  !! This AbstractSoilLayer instance
            integer :: t                                    !! The current time step
            real(dp) :: q_in                                !! Water into the layer on this time step [m/timestep]
            real(dp) :: m_np_in(:,:,:)                      !! NM into the layer on this time step [kg/timestep]
            real(dp) :: m_transformed_in(:,:,:)             !! Transformed NM into the layer on this time step [kg/timestep]
            real(dp) :: m_dissolved_in                      !! Dissolved species into the layer on this time step [kg/timestep]
            type(Result) :: r                               !! The `Result` object to return, with no data
        end function

        !> Add a volume \( V_{\text{pool}} \) of pooled water to the layer.
        !! No percolation occurs as pooled water never really leaves the AbstractSoilLayer.
        function addPooledWaterAbstractSoilLayer(me, V_pool) result(r)
            use ResultModule, only: Result
            use Globals, only: dp
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me                  !! This AbstractSoilLayer instance
            real(dp) :: V_pool                              !! Volume of pooled water to add, \( V_{\text{pool}} \) [m3/m2]
            type(Result) :: r                               !! The `Result` object to return, with no data
        end function

        !> Erode NM from this soil layer
        function erodeAbstractSoilLayer(me, erodedSediment, bulkDensity, area) result(r)
            use ResultModule, only: Result
            use Globals, only: dp, C
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me
            real(dp) :: erodedSediment(:)
            real(dp)            :: bulkDensity
            real(dp)            :: area
            type(Result) :: r
        end function

        function calculateBioturbationRateAbstractSoilLayer(me) result(bioturbationRate)
            use Globals, only: dp
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me
            real(dp) :: bioturbationRate
        end function

        !> Parse the data input for this AbstractSoilLayer
        function parseInputDataAbstractSoilLayer(me) result(r)
            use ResultModule, only: Result
            use Globals, only: dp
            import AbstractSoilLayer
            class(AbstractSoilLayer) :: me                  !! This AbstractSoilLayer instance
            type(Result) :: r
                !! The Result object to return any errors relating to the input data file
        end function
    end interface

  contains

    !> Set the volume of pooled water
    subroutine setV_pool(me, V_pool)
        class(AbstractSoilLayer) :: me                      !! This AbstractSoilLayer instance
        real(dp) :: V_pool                                  !! The pooled water [m3/m2]
        me%V_pool = V_pool
    end subroutine

end module


      PROGRAM CALL_DASPK

      IMPLICIT NONE

C IN THIS CODE WE ASSUME THAT THE
C MAXIMUM # SPECIES = 1500
C MAXIMUM # REACTIONS = 100,000
C MAXIMUM # THIRDBODYREACTIONS = 100
C MAXIMUM # TROEREACTIONS = 100

      INTEGER SPMAX, RMAX, TBRMAX, TROEMAX
      PARAMETER (SPMAX = 1500, RMAX = 100000, TBRMAX=100, TROEMAX=100)

      INTEGER NSTATE, INFO(30), IWORK(1541), LRW, LIW, NEQ,
     $     REACTIONSIZE, THIRDBODYREACTIONSIZE, TROEREACTIONSIZE,
     $     REACTIONARRAY(9*RMAX), THIRDBODYREACTIONARRAY(20*TBRMAX),
     $     TROEREACTIONARRAY(21*TROEMAX), I, J, IDID, impspecies

      DOUBLE PRECISION Y(SPMAX), YPRIME(SPMAX), T, TOUT, RTOL, ATOL,
     $     RWORK(51+9*SPMAX+SPMAX**2), TEMPERATURE, PRESSURE,
     $     REACTIONRATEARRAY(5*rmax),
     $     THIRDBODYREACTIONRATEARRAY(16*Tbrmax),
     $     TROEREACTIONRATEARRAY(21*TROemax), targetconc

      COMMON /SIZE/ NSTATE, REACTIONSIZE, THIRDBODYREACTIONSIZE,
     $     TROEREACTIONSIZE

      COMMON /REAC/ REACTIONRATEARRAY, THIRDBODYREACTIONRATEARRAY,
     $     TROEREACTIONRATEARRAY, temperature, pressure,
     $     REACTIONARRAY, THIRDBODYREACTIONARRAY,
     $     TROEREACTIONARRAY

      OPEN (UNIT=12, FILE = 'SolverInput.dat', STATUS = 'OLD')

C READ THE NUMBER OF SPECIES
      READ(12,*) NSTATE, NEQ, IMPSPECIES, TARGETCONC
      NSTATE = NSTATE+1

C  READ THE CONCENTRATIONS
      READ(12,*) (Y(I), i=1,nstate-1)

C READ THE RATE OF CHANGE OF CONCENTRATIONS
      READ(12,*) (YPRIME(I), i=1,nstate-1)
      YPRIME(NSTATE) = 0;

c READ THE TIME AND TOUT
      READ(12,*) T, TOUT

c READ THE INFO ARRAY
      READ(12,*) (INFO(I), I=1,30)

C READ RTOL AND ATOL
      READ(12,*) RTOL, ATOL

C READ TEMPERATURE AND PRESSURE
      READ(12,*) TEMPERATURE, PRESSURE

      Y(NSTATE) = 8.314*temperature/pressure/1e-6;
      do i=1,nstate-1
         y(i) = y(i)*y(nstate)
c         write(*,*) y(i)
      end do

C READ INFORMATION ABOUT REACTIONS
      READ(12,*) REACTIONSIZE
      READ(12,*) (REACTIONARRAY(I),I=1,9*REACTIONSIZE)
      READ(12,*) (REACTIONRATEARRAY(I),I=1,5*REACTIONSIZE)

C READ INFORMATION ABOUT THIRDBODYREACTIONS
      READ(12,*) THIRDBODYREACTIONSIZE
      READ(12,*)(THIRDBODYREACTIONARRAY(I),I=1,20*THIRDBODYREACTIONSIZE)
      READ(12,*)(THIRDBODYREACTIONRATEARRAY(I),I=1,16*THIRDBODYREACTIONS
     $     IZE)

C READ INFORMATION ABOUT TROEREACTIONS
      READ(12,*) TROEREACTIONSIZE
      READ(12,*)(TROEREACTIONARRAY(I),I=1,21*TROEREACTIONSIZE)
      READ(12,*)(TROEREACTIONRATEARRAY(I),I=1,21*TROEREACTIONSIZE)

c READ RWORK AND IWORK
      IF (T .NE. 0.0) THEN
         OPEN(UNIT=13, FILE = 'RWORK.DAT', FORM='UNFORMATTED')
         READ(13) (RWORK(I),I=1,51+9*NSTATE+NSTATE**2)

         OPEN(UNIT=14, FILE = 'IWORK.DAT', FORM='UNFORMATTED')
         READ(14) (IWORK(I),I=1, 41+NSTATE)
      END IF

      CALL SOLVEODE(Y, YPRIME, T, TOUT, INFO, RTOL, ATOL, IDID,
     $     RWORK, IWORK, IMPSPECIES, TARGETCONC)

      END PROGRAM CALL_DASPK

      SUBROUTINE JAC()
      END SUBROUTINE JAC

      SUBROUTINE SOLVEODE(Y, YPRIME, Time, TOUT, INFO, RTOL, ATOL,
     $     IDID, RWORK, IWORK, IMPSPECIES, TARGETCONC)

      IMPLICIT NONE

C     INITIALIZE VARIABLES IN COMMON BLOC
      INTEGER SPMAX, RMAX, TBRMAX, TROEMAX
      PARAMETER (SPMAX = 1500, RMAX = 100000, TBRMAX=100, TROEMAX=100)

      INTEGER REACTIONSIZE, THIRDBODYREACTIONSIZE, TROEREACTIONSIZE,
     $     REACTIONARRAY(9*RMAX), THIRDBODYREACTIONARRAY(20*TBRMAX),
     $     TROEREACTIONARRAY(21*TROEMAX), I, J, NSTATE

      DOUBLE PRECISION REACTIONRATEARRAY(5*rmax),
     $     THIRDBODYREACTIONRATEARRAY(16*Tbrmax),
     $     TROEREACTIONRATEARRAY(21*TROemax), TEMPERATURE, PRESSURE

      COMMON /SIZE/ NSTATE, REACTIONSIZE, THIRDBODYREACTIONSIZE,
     $     TROEREACTIONSIZE

      COMMON /REAC/ REACTIONRATEARRAY, THIRDBODYREACTIONRATEARRAY,
     $     TROEREACTIONRATEARRAY, temperature, pressure,
     $     REACTIONARRAY, THIRDBODYREACTIONARRAY,
     $     TROEREACTIONARRAY

      INTEGER  INFO(30), LIW, LRW, IWORK(*), IPAR(1),IDID, iter,
     $     IMPSPECIES, conc
      DOUBLE PRECISION Y(NSTATE), YPRIME(NSTATE), Time, TOUT, RTOL, ATOL
     $     , RWORK(*), TARGETCONC

      DOUBLE PRECISION RPAR(REACTIONSIZE+THIRDBODYREACTIONSIZE+
     $     TROEREACTIONSIZE),
     $     TotalReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+
     $     TROEREACTIONSIZE),
     $     CURRENTReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+
     $     TROEREACTIONSIZE),
     $     PREVReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+
     $     TROEREACTIONSIZE), PREVTIME

      EXTERNAL RES, JAC, GETFLUX

      conc = 1
      IPAR(1)= NSTATE

      LIW = 41 + NSTATE
      LRW = 51 + 9*NSTATE + NSTATE**2

C     ******* INITIALIZE THE REAL ARRAY
      DO I=0,REACTIONSIZE-1
         RPAR(I+1) = REACTIONRATEARRAY(5*I+1)
      END DO

      DO I=0,THIRDBODYREACTIONSIZE-1
         RPAR(REACTIONSIZE+I+1) = THIRDBODYREACTIONRATEARRAY(16*I+1)
      END DO

      DO I=0,TROEREACTIONSIZE-1
         RPAR(REACTIONSIZE+THIRDBODYREACTIONSIZE+I+1) =
     $        TROEREACTIONRATEARRAY(21*I+1)
      END DO
C     **********************************

      CALL GETFLUX(Y, YPRIME, RPAR)

      iter = 0;
      PREVTIME = TIME
      DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE
         PREVREACTIONFLUX(I) = 0
         TOTALREACTIONFLUX(I) = 0
         CURRENTREACTIONFLUX(I) = 0
      END DO
      call Reaction_flux(y, prevreactionflux, rpar)

      IF (IMPSPECIES .EQ. -1) THEN
         TARGETCONC = -1E10
         IMPSPECIES = 1
         conc = -1
      END IF

 1    IF (Time .LE. TOUT .AND. Y(IMPSPECIES) .GE. TARGETCONC*Y(NSTATE))
     $     THEN

         CALL DDASSL(RES, NSTATE, Time, Y, YPRIME, TOUT, INFO, RTOL,
     $        Atol, IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
         IF (IDID .EQ. -1) THEN
            WRITE(*,*) "Warning: 500 steps were already taken, taking
     $           another 500 steps"
            INFO(1) = 1
            GO TO 1
         ELSE IF ( IDID .EQ. 1) THEN
            iter = iter + 1
            CALL REACTION_FLUX(Y, CURRENTREACTIONFLUX, RPAR)

            DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE
               TOTALREACTIONFLUX(I) = TOTALREACTIONFLUX(I) +
     $              (CURRENTREACTIONFLUX(I) + PREVREACTIONFLUX(I)) *
     $              (TIME - PREVTIME)/2
               PREVREACTIONFLUX(I) = CURRENTREACTIONFLUX(I)
            END DO
            PREVTIME = TIME
            if (conc .eq. 1) then
               tout = 200*time
            end if
c            write(*,*) time, y(impspecies), targetConc*y(nstate)
            GO TO 1
         END IF
      END IF

      OPEN(UNIT=16, FILE='SolverOutput.dat')

      write(16,*) iter
      WRITE(16,*) NSTATE-1
      write(16,*) time
      DO I=1,NSTATE-1
         WRITE(16,*) Y(I)/Y(NSTATE)
      END DO

      DO I=1,NSTATE-1
         WRITE(16,*) YPRIME(I)/Y(NSTATE)
      END DO

      DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE
         WRITE(16,*) TOTALREACTIONFLUX(I)
      END DO

      write(16,*) y(nstate)

      CLOSE(16)

      OPEN(UNIT=14, FILE='RWORK.DAT', FORM='UNFORMATTED')
      WRITE(14) (RWORK(I),I=1,LRW)
      CLOSE(14)

      OPEN(UNIT=15, FILE='IWORK.DAT', FORM='UNFORMATTED')
      WRITE(15) (IWORK(I),I=1,LIW)
      CLOSE(15)

      if (idid .eq. 1 .or. idid .eq. 2 .or. idid .eq. 3) then
         WRITE(*,*) "******ODESOLVER SUCCESSFUL: IDID=",idid
      else
         WRITE(*,*) "******ODESOLVER FAILED : IDID=", idid
      end if
c      write(*,*) yprime(nstate)
      END SUBROUTINE SOLVEode