      subroutine geneq1_ani(i)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To generate equations heat and mass transfer solution at each node.
!D1 anisotropic permeability
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Revision                    E!D
!D2 Date         Programmer     Number  Comments
!D2
!D2 Initial implementation: 01-april-2010, Programmer: G. Zyvoloski
!D2
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.2 Heat- and mass-transfer equations
!D3 2.3.3 Noncondensible gas flow equations
!D3
!**********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 3.06
!D4
!**********************************************************************
      use comflow
      use davidi
      use comji
      use comfi
      use comgi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      implicit none

      integer i
      integer icd
      integer ii1
      integer ii2
      integer idg
      integer iq
      integer jmi
      integer jml
      integer jmia
      integer jm
      integer neqp1
      integer ij
      integer ij1
      integer ij2
      integer iz
      integer kb
      integer neighc
      integer iau
      integer ial
      integer kz
      integer nmatavw
      real*8 sx1d
      real*8 axi
      real*8 ayi
      real*8 azi
      real*8 alxi
      real*8 alyi
      real*8 alzi
      real*8 avxi
      real*8 avyi
      real*8 avzi
      real*8 pvii
      real*8 phii
      real*8 swi
      real*8 dlpi
      real*8 dlpkb
      real*8 dvpi
      real*8 dvpkb
      real*8 dlei
      real*8 dvei
      real*8 dlekb
      real*8 dvekb
      real*8 dlapi
      real*8 dvapi
      real*8 dlapkb
      real*8 dvapkb
      real*8 dili
      real*8 dilkb
      real*8 divi
      real*8 divkb
      real*8 axkb
      real*8 aykb
      real*8 azkb
      real*8 alxkb
      real*8 alykb
      real*8 alzkb
      real*8 sx2c
      real*8 sx4d
c     real*8 sxzc
      real*8 pvikb
      real*8 phikb
      real*8 radi
      real*8 radkb
      real*8 fid
      real*8 fid1
      real*8 axyd
      real*8 axy
      real*8 axyf
      real*8 heatc
      real*8 pvxy
      real*8 pxy
      real*8 pxyh
      real*8 pxyi
      real*8 sx4h
      real*8 vxyd
      real*8 vxy
      real*8 vxyf
      real*8 dpvti
      real*8 dilpi
      real*8 dilei
      real*8 divpi
      real*8 divei
      real*8 dilpkb
      real*8 divpkb
      real*8 divekb
      real*8 dilekb
      real*8 sx2t
      real*8 sx3t
      real*8 sxzt
      real*8 sx3c
      real*8 dlaei
      real*8 dlaekb
      real*8 dvaei
      real*8 dvaekb
      real*8 dis2,dis_tol,sx_min
      real*8 delx2
      real*8 dely2
      real*8 delz2
      real*8 reduction_factor
      real*8 grav_air
      real*8 grav_term
      real*8  thxi, thxkb, thyi, thykb, thzi, thzkb, ti

      parameter(dis_tol=1.d-12)

      logical bit
      integer isl
      integer iz4m1
      integer imd,iwd
      integer i1,i2,j,kb1,kb2,kz1,kz2,iface
      integer kb_adv_x,kb_adv_y,kb_adv_z
      integer ij_x,ij_y,ij_z,ji_x,ji_y,ji_z
      integer iqx,iqy,iqz,kc,kd,jj,i3,i4
      integer iqxm,iqym,iqzm

      integer neq1,neq2,neq3,neq4

      real*8 flux_x,flux_y,flux_z,flux_dir(3)
      real*8 dfxpi,dfxpkb,dfxpkb1,dfxpkb2
      real*8 dfypi,dfypkb,dfypkb1,dfypkb2
      real*8 dfzpi,dfzpkb,dfzpkb1,dfzpkb2
      real*8 dfxpkb1a,dfxpkb2a,dfypkb1a,dfypkb2a
      real*8 dfzpkb1a,dfzpkb2a
      real*8 pvikb1,phikb1,pvikb2,phikb2
      real*8 daxyfpi ,daxyfpkb
      real*8 sumx,sumy,sumz,termx,termy,termz
      real*8 presd1,presd2,cordd1,cordd2
      real*8 sumxg,sumyg,sumzg,dsumxp,dsumyp,dsumzp
      real*8 dend,ddendpi,ddendpkb

      real*8 dfxei,dfxekb,daxyfei,daxyfekb
      real*8 ddendei,ddendekb
      real*8 dfyei,dfyekb
      real*8 dfzei,dfzekb

      real*8  enli, enlkb, envi, envkb
      real*8  deli,delei,devi,devei,delkb,delekb,aexyf
      real*8 flux_xe, flux_ye, flux_ze
      real*8 daexyfpi,daexyfpkb,dfxepi,dfxepkb,daexyfei,daexyfekb
      real*8 dfxeei,dfxeekb

c changed by avw -- entered here by seh
      neqp1=neq+1
      neq1 = neq
      neq2 = neq1 + neq
      neq3 = neq2 + neq
      neq4 = neq3 + neq
      if(i.gt.neq) then
         nmatavw=ldna
      else
         nmatavw=0
      endif
      if(icons.le.abs(maxit)) then
       grav_air=0.0
      else
       grav_air=grav
      endif

c
c zero out temporary storage
c
      if(.not.allocated(dum_ani)) then
       allocate(dum_ani(neq4))
       allocate(dumx_ani(neq4))
       allocate(dumy_ani(neq4))
       allocate(dumz_ani(neq4))
       allocate(it4a(200))
       allocate(it5a(200))
       allocate(it6a(200))
      endif
c
c storage for upwind
c
      sx1d=sx1(i)
      axi=pnx(i)
      ayi=pny(i)
      azi=pnz(i)
      alxi=axi
      avxi=axi
      alyi=ayi
      avyi=ayi
      alzi=azi
      avzi=azi
      pvii=phi(i)
      dili=dil(i)
      dilpi=dilp(i)
        phii=pvii-pcp(i)
        dpvti=dpcef(i)
        divi=div(i)
        divpi=divp(i)
        divei=dive(i)
        dilei=dile(i)
      enli=enlf(i)
      deli=delf(i)
      delei=delef(i)
      envi=envf(i)
      devi=devf(i)
      devei=devef(i)
      ti=t(i)
      thxi=thx(i)
      thyi=thy(i)
      thzi=thz(i)

c
c form constants for i>neq
c
      if(i.gt.neq.and.idualp.eq.0) then
         icd=neq
      else
         icd=0
      endif
      iz=i-icd
c
      iz4m1 = 4*(iz-1)+1
c
      idg=nelmdg(i-icd)-ii1+1
      neqp1=neq+1
c define diagonal term for connectivity
      jmi=nelmdg(i-icd)
c define diagonal term for jacobian matrix
      jmia=jmi-neqp1

c Take care of source/sink term by putting it into empty slot (from
c same node to same node).
c If this is an isothermal air-water simulation
      a_axy(jmia+nmatavw)=sk(i)
c Take care of source/sink term
c If this is an isothermal air-water simulation
c      a_vxy(jmia+nmatavw)=qh(i)

c
c   anisotropy coding
c
c   x face terms
      ii1=icxani(i-icd)+1
      ii2=icxani(i-icd+1)
      iqx=0
      do  jm=ii1,ii2
       iqx=iqx+1
       kb1 = ncon_x1(jm)
       kb2 = ncon_x2(jm)
       termx = sx_x(jm)
       it4(iqx)= kb1
       it4a(iqx)= kb2
       t1(iqx)=termx
      enddo
c   y face terms
      ii1=icyani(i-icd)+1
      ii2=icyani(i-icd+1)
      iqy=0
      do  jm=ii1,ii2
       iqy=iqy+1
       kb1 = ncon_y1(jm)
       kb2 = ncon_y2(jm)
       termy = sx_y(jm)
       it5(iqy)=kb1
       it5a(iqy)=kb2
       t2(iqy)=termy
      enddo
c   z face terms
c
c   note using -termz
c
      ii1=iczani(i-icd)+1
      ii2=iczani(i-icd+1)
      iqz=0
      do  jm=ii1,ii2
       iqz=iqz+1
       kb1 = ncon_z1(jm)
       kb2 = ncon_z2(jm)
       termz = sx_z(jm)
       it6(iqz)=kb1
       it6a(iqz) = kb2
       t3(iqz)=termz
      enddo
c
c create correspondence with array connectivity
c
         kb_adv_x = ncon_adv(iz,1)
         kb_adv_y = ncon_adv(iz,2)
         kb_adv_z = ncon_adv(iz,3)

c note must search below diagonal because + face node can be < iz
c figure this out once above
           i1 = nelm(iz)+1
           i2 = nelm(iz+1)
           iq = 0
           do jj= i1,i2
            kb = nelm(jj)
            iq = iq +1
             it8(iq) = kb
             it9(iq) = jj - neqp1
           enddo
c  find -x positions
          iqxm = 0
          if(kb_adv_x.gt.0) then
           i3 = nelm(kb_adv_x)+1
           i4 = nelm(kb_adv_x+1)
            do kd = i3,i4
             iqxm = iqxm +1
             kc = nelm(kd)
              it11(iqxm) = kc
              it11a(iqxm) = kd - neqp1
           enddo
          endif
c  find -y positions
          iqym = 0
          if(kb_adv_y.gt.0) then
           i3 = nelm(kb_adv_y)+1
           i4 = nelm(kb_adv_y+1)
            do kd = i3,i4
             iqym = iqym +1
             kc = nelm(kd)
              it12(iqym) = kc
              it12a(iqym) = kd - neqp1
           enddo
          endif
c  find -z positions
          iqzm = 0
          if(kb_adv_z.gt.0) then
           i3 = nelm(kb_adv_z)+1
           i4 = nelm(kb_adv_z+1)
            do kd = i3,i4
             iqzm = iqzm +1
             kc = nelm(kd)
              it13(iqzm) = kc
              it13a(iqzm) = kd - neqp1
           enddo
          endif

       do jm = 1,iq
        kb = it8(jm)
        dum_ani(kb)= 0.0
        dum_ani(kb+neq1)= 0.0
        dum_ani(kb+neq2)= 0.0
        dum_ani(kb+neq3)= 0.0
       enddo
        do jm = 1,iqxm
         kb = it11(jm)
         dumx_ani(kb) = 0.0
         dumx_ani(kb+neq1) = 0.0
         dumx_ani(kb+neq2) = 0.0
         dumx_ani(kb+neq3) = 0.0
       enddo
       do jm = 1,iqym
        kb = it12(jm)
         dumy_ani(kb) = 0.0
         dumy_ani(kb+neq1) = 0.0
         dumy_ani(kb+neq2) = 0.0
         dumy_ani(kb+neq3) = 0.0
       enddo
       do jm = 1,iqzm
        kb = it13(jm)
         dumz_ani(kb) = 0.0
         dumz_ani(kb+neq1) = 0.0
         dumz_ani(kb+neq2) = 0.0
         dumz_ani(kb+neq3) = 0.0
       enddo
c
c 3-d geometry
c
      if(icnl.eq.0) then
c
      if(irdof.ne.11) then
c
c liquid phase calculations
c
         flux_dir = 0.0
c  check x direction upwinding
        if(kb_adv_x.gt.0) then
         sumx = 0.0
         sumxg = 0.0
         do jm=1,iqx
            kb1=it4(jm)
            kz1=kb1-icd
            kb2=it4a(jm)
            kz2=kb2-icd
            if (irdof .ne. 13) then
             presd1 = phi(kb1)-pcp(kb1)
             presd2 = phi(kb2)-pcp(kb2)
            else
             presd1 = phi(kb1)
             presd2 = phi(kb2)
            endif
            cordd1 = cord(kz1,igrav)
            cordd2 = cord(kz2,igrav)
            sumx = sumx + t1(jm)*(presd1-presd2)
            sumxg = sumxg + t1(jm)*(cordd1-cordd2)
         enddo
         flux_dir(1) = sumx -
     &        0.5*grav*(rolf(iz)+rolf(kb_adv_x))*sumxg
        endif
c  check y direction upwinding
        if(kb_adv_y.gt.0) then
         sumy = 0.0
         sumyg = 0.0
         do jm=1,iqy
            kb1=it5(jm)
            kz1=kb1-icd
            kb2=it5a(jm)
            kz2=kb2-icd
            if (irdof .ne. 13) then
             presd1 = phi(kb1)-pcp(kb1)
             presd2 = phi(kb2)-pcp(kb2)
            else
             presd1 = phi(kb1)
             presd2 = phi(kb2)
            endif
            cordd1 = cord(kz1,igrav)
            cordd2 = cord(kz2,igrav)
            sumy = sumy + t2(jm)*(presd1-presd2)
            sumyg = sumyg + t2(jm)*(cordd1-cordd2)
         enddo
         flux_dir(2) = sumy -
     &        0.5*grav*(rolf(iz)+rolf(kb_adv_y))*sumyg
        endif
c  check z direction upwinding
        if(kb_adv_z.gt.0) then
         sumz = 0.0
         sumzg = 0.0
         do jm=1,iqz
            kb1=it6(jm)
            kz1=kb1-icd
            kb2=it6a(jm)
            kz2=kb2-icd
            if (irdof .ne. 13) then
             presd1 = phi(kb1)-pcp(kb1)
             presd2 = phi(kb2)-pcp(kb2)
            else
             presd1 = phi(kb1)
             presd2 = phi(kb2)
            endif
            cordd1 = cord(kz1,igrav)
            cordd2 = cord(kz2,igrav)
            sumz = sumz + t3(jm)*(presd1-presd2)
            sumzg = sumzg + t3(jm)*(cordd1-cordd2)
         enddo
         flux_dir(3) = sumz -
     &        0.5*grav*(rolf(iz)+rolf(kb_adv_z))*sumzg
        endif
c
c determine upwind nodes and if liquid phase exists
c
         isl=1
         do iface=1,3
c
c coding to save upwind position
c
          if(iad.le.iad_up) then
            fid=0.5
            axyd=flux_dir(iface)
            if(axyd.lt.0.0) fid=dnwgt
            if(axyd.gt.0.0) fid=upwgt
            t9(iface)=fid
c
            call setbit(nbits,iface,upwind_l(iz4m1),fid)
c
          else
           if(bit(nbits,iface,upwind_l(iz4m1))) then
            t9(iface )=1.0

           else
            t9(iface )=0.0

           endif
          endif
         enddo
c
c form equations
c
         if(isl.ne.0) then
c     + x face
          if(kb_adv_x.ne.0) then
           dilkb=dil(kb_adv_x)
           dilpkb=dilp(kb_adv_x)
           fid=t9(1)
           fid1=1.0-fid
           axyf=(fid*dilkb+fid1*dili)
           dend=-(rolf(iz)+rolf(kb_adv_x))*0.5*grav
           ddendpi = -0.5*grav*dglp(iz)
           ddendpkb = -0.5*grav*dglp(kb_adv_x)
           daxyfpi = fid1*dilpi
           daxyfpkb = fid*dilpkb
           enlkb=enlf(kb_adv_x)
           delkb=delf(kb_adv_x)
	     delekb=delef(kb_adv_x)
           dilekb=dile(kb_adv_x)
           dilekb=dile(kb_adv_x)
           ddendei = -0.5*grav*dgle(iz)
           ddendekb = -0.5*grav*dgle(kb_adv_x)
           aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
            do  jm=1,iqx
               kb1=it4(jm)
               kz1=kb1-icd
               kb2=it4a(jm)
               kz2=kb2-icd
               dsumxp = t1(jm)
c mass eq (primary) pressure derivative
               dum_ani(kb1) = dum_ani(kb1) + axyf*dsumxp
               dumx_ani(kb1) = dumx_ani(kb1) - axyf*dsumxp
               dum_ani(kb2) = dum_ani(kb2) - axyf*dsumxp
               dumx_ani(kb2) = dumx_ani(kb2) + axyf*dsumxp
c energy eq (primary) pressure derivative
               dum_ani(kb1+neq2) = dum_ani(kb1+neq2) + aexyf*dsumxp
               dumx_ani(kb1+neq2) = dumx_ani(kb1+neq2) - aexyf*dsumxp
               dum_ani(kb2+neq2) = dum_ani(kb2+neq2) - aexyf*dsumxp
               dumx_ani(kb2+neq2) = dumx_ani(kb2+neq2) + aexyf*dsumxp
            enddo
c mass equation terms
           flux_x = axyf*(sumx + dend*sumxg)
c flow terms for mass equation, derivatives wrt pressure
           dfxpi = daxyfpi*(sumx + dend*sumxg) +
     &                  axyf*ddendpi*sumxg
           dfxpkb = daxyfpkb*(sumx + dend*sumxg) +
     &                   axyf*ddendpkb*sumxg
           dum_ani(iz) = dum_ani(iz) + dfxpi
           dum_ani(kb_adv_x) = dum_ani(kb_adv_x) + dfxpkb
           dumx_ani(iz) = dumx_ani(iz) - dfxpi
           dumx_ani(kb_adv_x) = dumx_ani(kb_adv_x) - dfxpkb
c flow terms for mass equation, derivatives wrt energy variable
            daxyfei = fid1*dilei
            daxyfekb = fid*dilekb
            dfxei = daxyfei*(sumx + dend*sumxg) +
     &                  axyf*ddendei*sumxg
            dfxekb = daxyfekb*(sumx + dend*sumxg) +
     &                   axyf*ddendekb*sumxg
            dum_ani(iz+neq1) = dum_ani(iz+neq1) + dfxei
            dum_ani(kb_adv_x+neq1) = dum_ani(kb_adv_x+neq1) + dfxekb
            dumx_ani(iz+neq1) = dumx_ani(iz+neq1) - dfxei
            dumx_ani(kb_adv_x+neq1) = dumx_ani(kb_adv_x+neq1) - dfxekb
c add to balance equation
           bp(iz+nrhs(1))=bp(iz+nrhs(1))+flux_x
           bp(kb_adv_x+nrhs(1))=bp(kb_adv_x+nrhs(1))-flux_x
c
c energy equation terms
c
c           enlkb=enlf(kb_adv_x)
c           delkb=delf(kb_adv_x)
c	      delekb=delef(kb_adv_x)
c           dilekb=dile(kb_adv_x)
c           aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
           flux_xe = aexyf*(sumx + dend*sumxg)
           daexyfpi = fid1*(dilpi*enli+dili*deli)
           daexyfpkb = fid*(dilpkb*enlkb+dilkb*delkb)
c flow terms for energy equation, derivatives wrt pressure
           dfxepi = daexyfpi*(sumx + dend*sumxg) +
     &                  aexyf*ddendpi*sumxg
           dfxepkb = daexyfpkb*(sumx + dend*sumxg) +
     &                   aexyf*ddendpkb*sumxg
           dum_ani(iz+neq2) = dum_ani(iz+neq2) + dfxepi
           dum_ani(kb_adv_x+neq2) = dum_ani(kb_adv_x+neq2) + dfxepkb
           dumx_ani(iz+neq2) = dumx_ani(iz+neq2) - dfxepi
           dumx_ani(kb_adv_x+neq2) = dumx_ani(kb_adv_x+neq2) - dfxepkb
c flow terms for energy equation, derivatives wrt energy variable
            dilekb=dile(kb_adv_x)
            ddendei = -0.5*grav*dgle(iz)
            ddendekb = -0.5*grav*dgle(kb_adv_x)
            daexyfei = fid1*(dilei*enli+dili*delei)
            daexyfekb = fid*(dilekb*enlkb+dilkb*delekb)
            dfxeei = daexyfei*(sumx + dend*sumxg) +
     &                  aexyf*ddendei*sumxg
            dfxeekb = daexyfekb*(sumx + dend*sumxg) +
     &                   aexyf*ddendekb*sumxg
            dum_ani(iz+neq3) = dum_ani(iz+neq3) + dfxeei
            dum_ani(kb_adv_x+neq3) = dum_ani(kb_adv_x+neq3) + dfxeekb
            dumx_ani(iz+neq3) = dumx_ani(iz+neq3) - dfxeei
            dumx_ani(kb_adv_x+neq3) = dumx_ani(kb_adv_x+neq3) - dfxeekb
c add to balance equation
           bp(iz+nrhs(2))=bp(iz+nrhs(2))+flux_xe
           bp(kb_adv_x+nrhs(2))=bp(kb_adv_x+nrhs(2))-flux_xe
          endif
c     + y face
          if(kb_adv_y.ne.0) then
           dilkb=dil(kb_adv_y)
           dilpkb=dilp(kb_adv_y)
           fid=t9(2)
           fid1=1.0-fid
           axyf=(fid*dilkb+fid1*dili)
           dend=-(rolf(iz)+rolf(kb_adv_y))*0.5*grav
           ddendpi = -0.5*grav*dglp(iz)
           ddendpkb = -0.5*grav*dglp(kb_adv_y)
           daxyfpi = fid1*dilpi
           daxyfpkb = fid*dilpkb
           enlkb=enlf(kb_adv_y)
           delkb=delf(kb_adv_y)
	     delekb=delef(kb_adv_y)
           dilekb=dile(kb_adv_y)
           dilekb=dile(kb_adv_y)
           ddendei = -0.5*grav*dgle(iz)
           ddendekb = -0.5*grav*dgle(kb_adv_y)
           aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
            do  jm=1,iqy
               kb1=it5(jm)
               kz1=kb1-icd
               kb2=it5a(jm)
               kz2=kb2-icd
               dsumyp = t2(jm)
c mass eq (primary) pressure derivative
               dum_ani(kb1) = dum_ani(kb1) + axyf*dsumyp
               dumy_ani(kb1) = dumy_ani(kb1) - axyf*dsumyp
               dum_ani(kb2) = dum_ani(kb2) - axyf*dsumyp
               dumy_ani(kb2) = dumy_ani(kb2) + axyf*dsumyp
c energy eq (primary) pressure derivative
               dum_ani(kb1+neq2) = dum_ani(kb1+neq2) + aexyf*dsumyp
               dumy_ani(kb1+neq2) = dumy_ani(kb1+neq2) - aexyf*dsumyp
               dum_ani(kb2+neq2) = dum_ani(kb2+neq2) - aexyf*dsumyp
               dumy_ani(kb2+neq2) = dumy_ani(kb2+neq2) + aexyf*dsumyp
            enddo
c mass equation terms
           flux_y = axyf*(sumy + dend*sumyg)
c flow terms for mass equation, derivatives wrt pressure
           dfxpi = daxyfpi*(sumy + dend*sumyg) +
     &                  axyf*ddendpi*sumyg
           dfxpkb = daxyfpkb*(sumy + dend*sumyg) +
     &                   axyf*ddendpkb*sumyg
           dum_ani(iz) = dum_ani(iz) + dfxpi
           dum_ani(kb_adv_y) = dum_ani(kb_adv_y) + dfxpkb
           dumy_ani(iz) = dumy_ani(iz) - dfxpi
           dumy_ani(kb_adv_y) = dumy_ani(kb_adv_y) - dfxpkb
c flow terms for mass equation, derivatives wrt energy variable
c            ddendei = -0.5*grav*dgle(iz)
c            ddendekb = -0.5*grav*dgle(kb_adv_y)
            daxyfei = fid1*dilei
            daxyfekb = fid*dilekb
            dfxei = daxyfei*(sumy + dend*sumyg) +
     &                  axyf*ddendei*sumyg
            dfxekb = daxyfekb*(sumy + dend*sumyg) +
     &                   axyf*ddendekb*sumyg
            dum_ani(iz+neq1) = dum_ani(iz+neq1) + dfxei
            dum_ani(kb_adv_y+neq1) = dum_ani(kb_adv_y+neq1) + dfxekb
            dumy_ani(iz+neq1) = dumy_ani(iz+neq1) - dfxei
            dumy_ani(kb_adv_y+neq1) = dumy_ani(kb_adv_y+neq1) - dfxekb
c add to balance equation
           bp(iz+nrhs(1))=bp(iz+nrhs(1))+flux_y
           bp(kb_adv_y+nrhs(1))=bp(kb_adv_y+nrhs(1))-flux_y
c
c energy equation terms
c
           flux_ye = aexyf*(sumy + dend*sumyg)
           daexyfpi = fid1*(dilpi*enli+dili*deli)
           daexyfpkb = fid*(dilpkb*enlkb+dilkb*delkb)
c flow terms for energy equation, derivatives wrt pressure
           dfxepi = daexyfpi*(sumy + dend*sumyg) +
     &                  aexyf*ddendpi*sumyg
           dfxepkb = daexyfpkb*(sumy + dend*sumyg) +
     &                   aexyf*ddendpkb*sumyg
           dum_ani(iz+neq2) = dum_ani(iz+neq2) + dfxepi
           dum_ani(kb_adv_y+neq2) = dum_ani(kb_adv_y+neq2) + dfxepkb
           dumy_ani(iz+neq2) = dumy_ani(iz+neq2) - dfxepi
           dumy_ani(kb_adv_y+neq2) = dumy_ani(kb_adv_y+neq2) - dfxepkb
c flow terms for energy equation, derivatives wrt energy variable
c            dilekb=dile(kb_adv_y)
c            ddendei = -0.5*grav*dgle(iz)
c            ddendekb = -0.5*grav*dgle(kb_adv_y)
            daexyfei = fid1*(dilei*enli+dili*delei)
            daexyfekb = fid*(dilekb*enlkb+dilkb*delekb)
            dfxeei = daexyfei*(sumy + dend*sumyg) +
     &                  aexyf*ddendei*sumyg
            dfxeekb = daexyfekb*(sumy + dend*sumyg) +
     &                   aexyf*ddendekb*sumyg
            dum_ani(iz+neq3) = dum_ani(iz+neq3) + dfxeei
            dum_ani(kb_adv_y+neq3) = dum_ani(kb_adv_y+neq3) + dfxeekb
            dumy_ani(iz+neq3) = dumy_ani(iz+neq3) - dfxeei
            dumy_ani(kb_adv_y+neq3) = dumy_ani(kb_adv_y+neq3) - dfxeekb
c add to balance equation
           bp(iz+nrhs(2))=bp(iz+nrhs(2))+flux_ye
           bp(kb_adv_y+nrhs(2))=bp(kb_adv_y+nrhs(2))-flux_ye
          endif
c     + z face
          if(kb_adv_z.ne.0) then
           dilkb=dil(kb_adv_z)
           dilpkb=dilp(kb_adv_z)
           fid=t9(3)
           fid1=1.0-fid
           axyf=(fid*dilkb+fid1*dili)
           dend=-(rolf(iz)+rolf(kb_adv_z))*0.5*grav
           ddendpi = -0.5*grav*dglp(iz)
           ddendpkb = -0.5*grav*dglp(kb_adv_z)
           daxyfpi = fid1*dilpi
           daxyfpkb = fid*dilpkb
           enlkb=enlf(kb_adv_z)
           delkb=delf(kb_adv_z)
	     delekb=delef(kb_adv_z)
           dilekb=dile(kb_adv_z)
           dilekb=dile(kb_adv_z)
           ddendei = -0.5*grav*dgle(iz)
           ddendekb = -0.5*grav*dgle(kb_adv_z)
           aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
            do  jm=1,iqz
               kb1=it6(jm)
               kz1=kb1-icd
               kb2=it6a(jm)
               kz2=kb2-icd
               dsumzp = t3(jm)
c mass eq (primary) pressure derivative
               dum_ani(kb1) = dum_ani(kb1) + axyf*dsumzp
               dumz_ani(kb1) = dumz_ani(kb1) - axyf*dsumzp
               dum_ani(kb2) = dum_ani(kb2) - axyf*dsumzp
               dumz_ani(kb2) = dumz_ani(kb2) + axyf*dsumzp
c energy eq (primary) pressure derivative
               dum_ani(kb1+neq2) = dum_ani(kb1+neq2) + aexyf*dsumzp
               dumz_ani(kb1+neq2) = dumz_ani(kb1+neq2) - aexyf*dsumzp
               dum_ani(kb2+neq2) = dum_ani(kb2+neq2) - aexyf*dsumzp
               dumz_ani(kb2+neq2) = dumz_ani(kb2+neq2) + aexyf*dsumzp
            enddo
c mass equation terms
           flux_z = axyf*(sumz + dend*sumzg)
c flow terms for mass equation, derivatives wrt pressure
           dfxpi = daxyfpi*(sumz + dend*sumzg) +
     &                  axyf*ddendpi*sumzg
           dfxpkb = daxyfpkb*(sumz + dend*sumzg) +
     &                   axyf*ddendpkb*sumzg
           dum_ani(iz) = dum_ani(iz) + dfxpi
           dum_ani(kb_adv_z) = dum_ani(kb_adv_z) + dfxpkb
           dumz_ani(iz) = dumz_ani(iz) - dfxpi
           dumz_ani(kb_adv_z) = dumz_ani(kb_adv_z) - dfxpkb
c flow terms for mass equation, derivatives wrt energy variable
c            dilekb=dile(kb_adv_z)
c            ddendei = -0.5*grav*dgle(iz)
c            ddendekb = -0.5*grav*dgle(kb_adv_z)
            daxyfei = fid1*dilei
            daxyfekb = fid*dilekb
            dfxei = daxyfei*(sumz + dend*sumzg) +
     &                  axyf*ddendei*sumzg
            dfxekb = daxyfekb*(sumz + dend*sumzg) +
     &                   axyf*ddendekb*sumzg
            dum_ani(iz+neq1) = dum_ani(iz+neq1) + dfxei
            dum_ani(kb_adv_z+neq1) = dum_ani(kb_adv_z+neq1) + dfxekb
            dumz_ani(iz+neq1) = dumz_ani(iz+neq1) - dfxei
            dumz_ani(kb_adv_z+neq1) = dumz_ani(kb_adv_z+neq1) - dfxekb
c add to balance equation
           bp(iz+nrhs(1))=bp(iz+nrhs(1))+flux_z
           bp(kb_adv_z+nrhs(1))=bp(kb_adv_z+nrhs(1))-flux_z
c
c energy equation terms
c
c           enlkb=enlf(kb_adv_z)
c           delkb=delf(kb_adv_z)
c	      delekb=delef(kb_adv_z)
c           dilekb=dile(kb_adv_z)
c           aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
           flux_ze = aexyf*(sumz + dend*sumzg)
           daexyfpi = fid1*(dilpi*enli+dili*deli)
           daexyfpkb = fid*(dilpkb*enlkb+dilkb*delkb)
c flow terms for energy equation, derivatives wrt pressure
           dfxepi = daexyfpi*(sumz + dend*sumzg) +
     &                  aexyf*ddendpi*sumzg
           dfxepkb = daexyfpkb*(sumz + dend*sumzg) +
     &                   aexyf*ddendpkb*sumzg
           dum_ani(iz+neq2) = dum_ani(iz+neq2) + dfxepi
           dum_ani(kb_adv_z+neq2) = dum_ani(kb_adv_z+neq2) + dfxepkb
           dumz_ani(iz+neq2) = dumz_ani(iz+neq2) - dfxepi
           dumz_ani(kb_adv_z+neq2) = dumz_ani(kb_adv_z+neq2) - dfxepkb
c flow terms for energy equation, derivatives wrt energy variable
            dilekb=dile(kb_adv_z)
            ddendei = -0.5*grav*dgle(iz)
            ddendekb = -0.5*grav*dgle(kb_adv_z)
            daexyfei = fid1*(dilei*enli+dili*delei)
            daexyfekb = fid*(dilekb*enlkb+dilkb*delekb)
            dfxeei = daexyfei*(sumz + dend*sumzg) +
     &                  aexyf*ddendei*sumzg
            dfxeekb = daexyfekb*(sumz + dend*sumzg) +
     &                   aexyf*ddendekb*sumzg
            dum_ani(iz+neq3) = dum_ani(iz+neq3) + dfxeei
            dum_ani(kb_adv_z+neq3) = dum_ani(kb_adv_z+neq3) + dfxeekb
            dumz_ani(iz+neq3) = dumz_ani(iz+neq3) - dfxeei
            dumz_ani(kb_adv_z+neq3) = dumz_ani(kb_adv_z+neq3) - dfxeekb
c add to balance equation
           bp(iz+nrhs(2))=bp(iz+nrhs(2))+flux_ze
           bp(kb_adv_z+nrhs(2))=bp(kb_adv_z+nrhs(2))-flux_ze
          endif
         endif
c
c  now load jacobian matrix (node i)
c
       do jm = 1,iq
        kb = it8(jm)
        jj = it9(jm)
         a(jj+nmat(1)) = a(jj+nmat(1)) + dum_ani(kb)
         a(jj+nmat(2)) = a(jj+nmat(2)) + dum_ani(kb+neq1)
         a(jj+nmat(3)) = a(jj+nmat(3)) + dum_ani(kb+neq2)
         a(jj+nmat(4)) = a(jj+nmat(4)) + dum_ani(kb+neq3)
       enddo
c
c  now load jacobian matrix (node kb_adv_x) (negative contribution)
c
       do jm = 1,iqxm
        kb = it11(jm)
        jj = it11a(jm)
         a(jj+nmat(1)) = a(jj+nmat(1)) + dumx_ani(kb)
	   a(jj+nmat(2)) = a(jj+nmat(2)) + dumx_ani(kb+neq1)
	   a(jj+nmat(3)) = a(jj+nmat(3)) + dumx_ani(kb+neq2)
         a(jj+nmat(4)) = a(jj+nmat(4)) + dumx_ani(kb+neq3)
       enddo
c
c  now load jacobian matrix (node kb_adv_y) (negative contribution)
c
       do jm = 1,iqym
        kb = it12(jm)
        jj = it12a(jm)
         a(jj+nmat(1)) = a(jj+nmat(1)) + dumy_ani(kb)
	   a(jj+nmat(2)) = a(jj+nmat(2)) + dumy_ani(kb+neq1)
	   a(jj+nmat(3)) = a(jj+nmat(3)) + dumy_ani(kb+neq2)
         a(jj+nmat(4)) = a(jj+nmat(4)) + dumy_ani(kb+neq3)
       enddo
c
c  now load jacobian matrix (node kb_adv_z) (negative contribution)
c
       do jm = 1,iqzm
        kb = it13(jm)
        jj = it13a(jm)
         a(jj+nmat(1)) = a(jj+nmat(1)) + dumz_ani(kb)
	   a(jj+nmat(2)) = a(jj+nmat(2)) + dumz_ani(kb+neq1)
	   a(jj+nmat(3)) = a(jj+nmat(3)) + dumz_ani(kb+neq2)
         a(jj+nmat(4)) = a(jj+nmat(4)) + dumz_ani(kb+neq3)
       enddo
c
c now load accumulation terms
c
      bp(iz+nrhs(1))=bp(iz+nrhs(1))+sx1d*deni(i)+sk(i)
      bp(iz+nrhs(2))=bp(iz+nrhs(2))+sx1d*denei(i)+qh(i)
      a(jmia+nmat(1))=a(jmia+nmat(1))+sx1d*dmpf(i)+dq(i)
      a(jmia+nmat(2))=a(jmia+nmat(2))+sx1d*dmef(i)+dqt(i)
      a(jmia+nmat(3))=a(jmia+nmat(3))+sx1d*depf(i)+dqh(i)
      a(jmia+nmat(4))=a(jmia+nmat(4))+sx1d*deef(i)+deqh(i)

      endif
      endif
c
c set up traditional pointers
c
        ii2=nelm(i-icd+1)
        jmi=nelmdg(i-icd)
        jmia=jmi-neqp1
        iq = 0
        do j=jmi+1,ii2
         kb = nelm(j)
         if(kb.le.neq_primary) then
          iq = iq+1
          i3 = nelmdg(kb)+1
          i4 = nelm(kb+1)
          it8(iq) = kb
          it10(iq) = istrw(j-neqp1)
          it11(iq)=j-neqp1
          ij1=nelm(kb)+1
          ij2=nelmdg(kb)-1
          do ij=ij1,ij2
           if(nelm(ij).eq.iz) then
            it12(iq)=ij-neqp1
            go to 1500
           endif
          enddo
         endif
1500    continue
        enddo
c
c add heat conduction
c
      do jm=1,iq
       iw = it10(jm)
       if(iw.gt.0)then
        kb=it8(jm)
        kz=kb-icd
        neighc=it9(jm)
        iau=it11(jm)
        ial=it12(jm)
        jml=nelmdg(kb)-neqp1
        thxkb=thx(kb)
        thykb=thy(kb)
        thzkb=thz(kb)
        sx2c=sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
        sx2t=2.*thxi*thxkb/(thxi+thxkb)
        sx3t=2.*thyi*thykb/(thyi+thykb)
        sxzt=2.*thzi*thzkb/(thzi+thzkb)
        delx2=(cord(kz,1)-cord(iz,1))**2
        dely2=(cord(kz,2)-cord(iz,2))**2
        delz2=(cord(kz,3)-cord(iz,3))**2
        dis2=delx2+dely2+delz2
        if(dis2.gt.dis_tol.and.iw.gt.0) then
          sx3c=sx2c*dis2/
     &    (delx2/sx2t+dely2/sx3t+
     &    delz2/sxzt)
        else
          sx3c=sx2c*sx_mult*max(sx2t,sx3t,sxzt)
        endif
        heatc=sx3c
        bp(iz+nrhs(2))=bp(iz+nrhs(2))+heatc*(t(kb)-ti)
        bp(kz+nrhs(2))=bp(kz+nrhs(2))-heatc*(t(kb)-ti)
        a(jmia+nmat(3))=a(jmia+nmat(3))-heatc*dtpa(i)
        a(jmia+nmat(4))=a(jmia+nmat(4))-heatc*dtpae(i)
        a(ial+nmat(3))=a(ial+nmat(3))+heatc*dtpa(i)
        a(ial+nmat(4))=a(ial+nmat(4))+heatc*dtpae(i)
        a(iau+nmat(3))=a(iau+nmat(3))+heatc*dtpa(kb)
        a(iau+nmat(4))=a(iau+nmat(4))+heatc*dtpae(kb)
        a(jml+nmat(3))=a(jml+nmat(3))-heatc*dtpa(kb)
        a(jml+nmat(4))=a(jml+nmat(4))-heatc*dtpae(kb)
       endif
      enddo
      if(irdof.ne.13) then
c
c vapour phase calculations
c

      endif
      return
      end


SUBROUTINE SET_ATOMIC_PARAMETERS(ATOMICSPECIE,MANIFOLD,JTOTAL_,ID,INFO)
  ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
  ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
  ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
  !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES

  USE ATOMIC_PROPERTIES
  USE TYPES

  IMPLICIT NONE
  CHARACTER (LEN=*),OPTIONAL, INTENT(IN) :: ATOMICSPECIE
  CHARACTER (LEN=*),OPTIONAL, INTENT(IN) :: MANIFOLD  !
  !  INTEGER,          OPTIONAL, INTENT(IN) :: JTOTAL
  DOUBLE PRECISION,  OPTIONAL, INTENT(IN) :: JTOTAL_
  TYPE(ATOM),INTENT(OUT) :: ID
  INTEGER, INTENT(INOUT) :: INFO

  DOUBLE PRECISION  JTOTAL
  JTOTAL = JTOTAL_/2.0
  !  IF(JTOTAL.NE.JTOTAL_) JTOTAL = JTOTAL_

  INFO = 4 !UNDEFINED ID
  IF(PRESENT(ATOMICSPECIE)) THEN
     SELECT CASE (ATOMICSPECIE)
     CASE("87Rb")
        mass_at = 87*amu
        I       = I_87Rb
        g_I     = g_I_87Rb
        J       = J_87Rb
        g_J     = g_J_87Rb
        A       = A_87Rb
        a_s     = a_s_87Rb
        alpha_E = alpha_E_87Rb
        Fup     = Fup_87Rb
        Fdown   = Fdown_87Rb
        INFO    = 1
        ID_name = ID_name_87Rb
        !        write(*,*) "# 87Rb"
     CASE ("6Li")
        mass_at = 6*amu
        I       = I_6Li
        g_I     = g_I_6Li
        J       = J_6Li
        g_J     = g_J_6Li
        A       = A_6Li
        a_s     = a_s_6Li
        alpha_E = alpha_E_6Li
        Fup     = Fup_6Li
        Fdown   = Fdown_6Li
        INFO    = 1  ! ITS AN ATOM
        ID_name = ID_name_6Li
        !write(*,*) "# 6Li"
     CASE ("85Rb")
        mass_at = mass_at_85Rb
        I       = I_85Rb
        g_I     = g_I_85Rb
        J       = J_85Rb
        g_J     = g_J_85Rb
        A       = A_85Rb
        a_s     = a_s_85Rb
        alpha_E = alpha_E_85Rb
        Fup     = Fup_85Rb
        Fdown   = Fdown_85Rb
        INFO    = 1  ! ITS AN ATOM
        ID_name = ID_name_85Rb
        !write(*,*) "# 6Li"
     CASE ("123Cs")
        mass_at = mass_at_123Cs
        I       = I_123Cs
        g_I     = g_I_123Cs
        J       = J_123Cs
        g_J     = g_J_123Cs
        A       = A_123Cs
        a_s     = a_s_123Cs
        alpha_E = alpha_E_123Cs
        Fup     = Fup_123Cs
        Fdown   = Fdown_123Cs
        INFO    = 1  ! ITS AN ATOM
        ID_name = ID_name_123Cs
        !write(*,*) "# 6Li"
     CASE ("41K")
        mass_at = mass_at_41K
        I       = I_41K
        g_I     = g_I_41K
        J       = J_41K
        g_J     = g_J_41K
        A       = A_41K
        a_s     = a_s_41K
        alpha_E = alpha_E_41K
        Fup     = Fup_41K
        Fdown   = Fdown_41K
        INFO    = 1  ! ITS AN ATOM
        ID_name = ID_name_41K
        !write(*,*) "# 6Li"
     CASE ("23Na")
        mass_at = mass_at_23Na
        I       = I_23Na
        g_I     = g_I_23Na
        J       = J_23Na
        g_J     = g_J_23Na
        A       = A_23Na
        a_s     = a_s_23Na
        alpha_E = alpha_E_23Na
        Fup     = Fup_23Na
        Fdown   = Fdown_23Na
        INFO    = 1  ! ITS AN ATOM
        ID_name = ID_name_23Na
     CASE("qubit")
        mass_at = amu
        I       = I_qubit
        g_I     = I_qubit
        J       = J_qubit
        g_J     = J_qubit
        A       = A_qubit
        a_s     = a_s_qubit
        alpha_E = alpha_E_qubit
        Fup     = Fup_qubit
        Fdown   = Fdown_qubit
        INFO    = 2 ! ITS A QUBIT
        ID_name = ID_name_qubit

        !write(*,*) "# qubit"
     CASE("spin")
        mass_at = amu
        I       = I_spin
        g_I     = I_spin
        J       = J_spin
        g_J     = J_spin
        A       = A_spin
        a_s     = a_s_spin
        alpha_E = alpha_E_spin
        Fup     = Fup_spin
        Fdown   = Fdown_spin
        INFO    = 3 ! ITS A SPIN
        ID_name = ID_name_spin

        !write(*,*) "# spin",Fup,Fdown
     CASE("lattice")
        INFO    = 5 ! ITS A lattice
        ID_name = ID_name_lattice

     END SELECT
  END IF
  IF(INFO.EQ.1) THEN
     ! HERE WE DEFINE THE ATOMIC PARAMETES ENTERING THE HAMILTONIAN.
     ! H = A I \cdot J + sum_fields mu_B g_J B \cdot J + mu_B g_I B \cdot I , when using the two mainifolds of the ground state
     ! H = sum_fields mu_B g_F B \cdot F

     J = L+S
     F    = Fup
     gF_2 = g_J*(F*(F+1) - I*(I+1) +J*(J+1))/(2*F*(F+1)) + g_I*(F*(F+1) + I*(I+1) - J*(J+1))/(2*F*(F+1))!
     F    = Fdown
     gF_1 = g_J*(F*(F+1) - I*(I+1) +J*(J+1))/(2*F*(F+1)) + g_I*(F*(F+1) + I*(I+1) - J*(J+1))/(2*F*(F+1))!
     G_F  = (g_J-g_I)/16.0
     IF(PRESENT(MANIFOLD)) THEN
        IF(MANIFOLD.EQ."U") THEN

           Ftotal           = Fup
           total_states_lsi = 2*Fup + 1
           gF               = gF_2
           ID%id_system = 1
           !write(*,*) Ftotal,total_states_lsi,gF
        ELSE  IF(MANIFOLD.EQ."L") THEN

           Ftotal           = Fdown
           total_states_lsi = 2*Fdown + 1
           gF               = gF_1
           ID%id_system = 2

        ELSE IF(MANIFOLD.EQ."B") THEN
           Ftotal = Fup

           !----- Counting the number of states
           J = L+S
           Total_states_LSI = 0
           DO WHILE(J.GE.ABS(L-S))
              F = I+J
              DO WHILE(F.GE.ABS(J-I))
                 !        write(*,*) Total_states_LSI,F,I,J
                 Total_states_LSI = Total_states_LSI + 2*int(F) + 1
                 F = F - 1
              END DO
              J= J - 1 ! only two values allowed for J: J = L+1/2 and J=L-1/2
           END DO
           J = L+S  ! reseting value of J modifeid before
           IF(s.eq.0.5 .and. i.LT.0.5) total_states_lsi = 2
           ID%id_system = 3
        END IF
     END IF
  ELSE IF(INFO .EQ. 2) THEN
     ! HERE WE DEFINE THE PARAMETERS OF THE QUBIT HAMILTONIAN
     ! H = HBAR OMEGA_0 S_x + HBAR OMEGA_T S_x + HBAR OMEGA_RABI cos(omega_1 t + phi)
     total_states_lsi = 2
     J  = 0.0
     S  = 0.5
     F  = 0.5
     L  = 0.0
     gF = 1.0
     Ftotal = 0.5
     ID%id_system = 4
  ELSE IF(INFO .EQ. 3) THEN
     ! HERE WE DEFINE THE PARRAMETES OF THE SPIN HAMILTONIAN
     ! H = HBAR OMEGA_0 S_x + HBAR OMEGA_T S_x + HBAR OMEGA_RABI cos(omega_1 t + phi)
     total_states_lsi = 2*JTOTAL + 1
     J      = 0.0
     S      = JTOTAL
     F      = JTOTAL
     L      = 0.0
     gF     = 1.0
     Ftotal = JTOTAL
     ID%id_system = 5
     !write(*,*) JTOTAL,total_states_lsi
  ELSE IF(INFO .EQ. 4) THEN
     ! HERE WE DEFINE THE PARAMETES OF THE LATTICE HAMILTONIAN
     ID%id_system = 6
     ID_name      = "unnamed"
  ELSE IF(INFO.EQ.5) THEN
     ID%id_system    = 7
     ID_name         = "lattice"
     IF(PRESENT(MANIFOLD)) PERIODIC        =  manifold ! boundary conditionss
     total_states_lsi = JTOTAL_   ! number of sites
  END IF
  !WRITE(*,*) 'set_atomic_properties',JTOTAL,JTOTAL_,TOTAL_STATES_LSI
  ID%D_bare = total_states_lsi

END SUBROUTINE SET_ATOMIC_PARAMETERS

SUBROUTINE DEALLOCATEALL(ID)

  USE ARRAYS
  USE MODES_4F

  IMPLICIT NONE
  INTEGER, INTENT(IN)::ID
  INTEGER :: r
  !  write(*,*) ID
  !IF(ALLOCATED(Energy)) DEALLOCATE(Energy)
  IF(ALLOCATED(H_IJ)) DEALLOCATE(H_IJ)
  IF(ALLOCATED(U_ZEEMAN)) DEALLOCATE(U_ZEEMAN)
  !  DEALLOCATE(U_RF)
  IF(ALLOCATED(HAMILTONIAN)) DEALLOCATE(HAMILTONIAN)
  !  DEALLOCATE(H_AUX)
  !  DEALLOCATE(H_RF)
  !  DEALLOCATE(H_RF_DAGGER)
  !  DEALLOCATE(H_MW)
  !  DEALLOCATE(H_ALPHA)
  !  DEALLOCATE(H_ALPHA_DAGGER)

  IF(ALLOCATED(j_x)) DEALLOCATE(j_x)
  IF(ALLOCATED(j_y)) DEALLOCATE(j_y)
  IF(ALLOCATED(j_z)) DEALLOCATE(j_z)
  IF(ALLOCATED(Identity)) DEALLOCATE(Identity)
  IF(ALLOCATED(H_FLOQUET)) DEALLOCATE(H_FLOQUET)
  IF(ALLOCATED(H_FLOQUET_COPY)) DEALLOCATE(H_FLOQUET_COPY)

  IF(ALLOCATED(VALUES__)) DEALLOCATE(VALUES__)
  IF(ALLOCATED(COLUMN__)) DEALLOCATE(COLUMN__)
  IF(ALLOCATED(ROW_INDEX__)) DEALLOCATE(ROW_INDEX__)

  IF(ALLOCATED(U_FD__)) DEALLOCATE(U_FD__)
  IF(ALLOCATED(E_DRESSED__)) DEALLOCATE(E_DRESSED__)

  IF(ALLOCATED(COUPLING)) THEN
     DO r=1,SIZE(COUPLING,1)
        DEALLOCATE(COUPLING(r)%V)
     END DO
     !WRITE(*,*) SIZE(COUPLING,1)
     DEALLOCATE(ATOM_%E_BARE)
     DEALLOCATE(COUPLING)
     COUPLINGALLOCATED = .FALSE.
  END IF

  SELECT CASE(ID)
  CASE(1)

  CASE(2)

  CASE(3)
     !     DEALLOCATE(jz_dash)
     DEALLOCATE(I_x)
     DEALLOCATE(I_y)
     DEALLOCATE(I_z)
     !     DEALLOCATE(CLEBSH_GORDAN_JtoF)

     !    DEALLOCATE(g_F_matrix)
     !    DEALLOCATE(Fx)
     !    DEALLOCATE(Fy)
     !    DEALLOCATE(Fz)
     !    DEALLOCATE(Fz_DASH)
     !    DEALLOCATE(Hamiltonian_F)
     !    DEALLOCATE(Identity_F)
     !    DEALLOCATE(F_t)
     !    DEALLOCATE(H_w)
     !    DEALLOCATE(H_M)
     !    DEALLOCATE(H_J)
  CASE(4)

  CASE(5)
     IF(ALLOCATED(j_x)) DEALLOCATE(j_x)
     IF(ALLOCATED(j_y)) DEALLOCATE(j_y)
     IF(ALLOCATED(j_z)) DEALLOCATE(j_z)
  END SELECT

END SUBROUTINE DEALLOCATEALL

MODULE FLOQUETINITINTERFACE
  INTERFACE FLOQUETINIT
     MODULE PROCEDURE FLOQUETINIT_QUBIT, FLOQUETINIT_SPIN,FLOQUETINIT_ALKALI,FLOQUETINIT_MBH
  END INTERFACE FLOQUETINIT
contains
  SUBROUTINE FLOQUETINIT_QUBIT(ID,atomicspecie,INFO)
    ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
    ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
    ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
    !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES
    ! calculate the dimenson of the Hilbert space
    ! initialize all the matrices required for a full Floquet calcuations
    ! Calculate the nuclear, electron and total angular momentum operators

    USE physical_constants ! Standard Module with constants
    USE ATOMIC_PROPERTIES  ! gF, F , etc. factors for several species
    USE subinterface       ! To ubroutines for representation of I and J operators
    USE ARRAYS
    USE SUBINTERFACE_LAPACK
    USE TYPES
    IMPLICIT NONE

    TYPE(ATOM),        INTENT(INOUT) :: ID
    CHARACTER (LEN=*), INTENT(IN)    :: ATOMICSPECIE
    INTEGER,           INTENT(INOUT) :: INFO

    INTEGER  r,D_F2,P,r_,p_
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE:: Energy
    !write(*,*)

    INFO = 4
    CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,'U',0.1D1,ID,INFO)
    !------ ALLOCATE NEEDED ARRAYS: Hamiltonian and Lapack
    !ALLOCATE(Energy(TOTAL_STATES_LSI))
    ALLOCATE(H_IJ(Total_states_LSI,Total_states_LSI))
    ALLOCATE(U_ZEEMAN(Total_states_LSI,Total_states_LSI))
    ALLOCATE(HAMILTONIAN(Total_states_LSI,Total_states_LSI))
    U_zeeman = 0

    IF(INFO.EQ.2) THEN
       ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
       CALL F_REPRESENTATION(j_x,j_y,j_z,0.05D1)
    END IF
    !write(*,*)"Floquet_qubit in floquet_init.f90 ", atomicspecie,info,id%d_bare
    !call write_matrix(J_x)
  END SUBROUTINE FLOQUETINIT_QUBIT

  SUBROUTINE FLOQUETINIT_SPIN(ID,atomicspecie,jtotal,info)
    ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
    ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
    ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
    !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES

    ! calculate the dimenson of the Hilbert space
    ! initialize all the matrices required for a full Floquet calcuations
    ! Calculate the nuclear, electron and total angular momentum operators

    USE physical_constants ! Standard Module with constants
    USE ATOMIC_PROPERTIES  ! gF, F , etc. factors for several species
    USE subinterface       ! To ubroutines for representation of I and J operators
    USE ARRAYS
    USE SUBINTERFACE_LAPACK
    USE TYPES
    IMPLICIT NONE

    TYPE(ATOM),        INTENT(INOUT) :: ID
    CHARACTER (LEN=*), INTENT(IN)    :: ATOMICSPECIE
    DOUBLE PRECISION,  intent(in)    :: jtotal
    INTEGER,           INTENT(INOUT) :: INFO

    INTEGER  r,D_F2,P,r_,p_
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE:: Energy

    !write(*,*) atomicspecie,JTOTAL
    INFO = 4
    CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,'B',JTOTAL,ID,INFO)
    !------ ALLOCATE NEEDED ARRAYS: Hamiltonian and Lapack
    ALLOCATE(Energy(TOTAL_STATES_LSI))
    ALLOCATE(H_IJ(Total_states_LSI,Total_states_LSI))
    ALLOCATE(U_ZEEMAN(Total_states_LSI,Total_states_LSI))
    ALLOCATE(HAMILTONIAN(Total_states_LSI,Total_states_LSI))
    U_zeeman = 0
    IF(INFO.EQ.3) THEN
       ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
       CALL F_REPRESENTATION(j_x,j_y,j_z,1.0D0*Ftotal)
    ELSE
       ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
       j_x = 0.0
       j_y = 0.0
       j_z = 0.0
    END IF

  END SUBROUTINE FLOQUETINIT_SPIN

  SUBROUTINE FLOQUETINIT_MBH(ID,atomicspecie,NP,L_,stats,info)
    ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
    ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
    ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
    !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES

    ! calculate the dimenson of the Hilbert space
    ! initialize all the matrices required for a full Floquet calcuations
    ! Calculate the nuclear, electron and total angular momentum operators

    USE physical_constants ! Standard Module with constants
    USE ATOMIC_PROPERTIES  ! gF, F , etc. factors for several species
    USE subinterface       ! To ubroutines for representation of I and J operators
    USE ARRAYS
    USE SUBINTERFACE_LAPACK
    USE TYPES
    IMPLICIT NONE

    TYPE(ATOM),        INTENT(INOUT) :: ID
    CHARACTER (LEN=*), INTENT(IN)    :: ATOMICSPECIE
    INTEGER,           intent(in)    :: NP,L_ !
    CHARACTER (LEN=*), INTENT(IN)    :: stats
    INTEGER,           INTENT(INOUT) :: INFO

    INTEGER  r,D_F2,P,r_,p_
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE:: Energy

    !  write(*,*) atomicspecie
    INFO = 6

    TOTAL_STATES_LSI =  1.0!D_H(L_,NP,stats)
    CALL SET_ATOMIC_PARAMETERS('lattice','B',1.0D0*total_states_lsi,ID,INFO)

    !------ ALLOCATE NEEDED ARRAYS: Hamiltonian and Lapack
    ALLOCATE(Energy(TOTAL_STATES_LSI))
    ALLOCATE(HAMILTONIAN(Total_states_LSI,Total_states_LSI))

  END SUBROUTINE FLOQUETINIT_MBH

  SUBROUTINE FLOQUETINIT_ALKALI(ID,atomicspecie,manifold,info)
    ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
    ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
    ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
    !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES

    ! calculate the dimenson of the Hilbert space
    ! initialize all the matrices required for a full Floquet calcuations
    ! Calculate the nuclear, electron and total angular momentum operators

    USE physical_constants ! Standard Module with constants
    USE ATOMIC_PROPERTIES  ! gF, F , etc. factors for several species
    USE subinterface       ! To ubroutines for representation of I and J operators
    USE ARRAYS
    USE SUBINTERFACE_LAPACK
    USE TYPES
    IMPLICIT NONE

    TYPE(ATOM),        INTENT(INOUT) :: ID
    CHARACTER (LEN=*), INTENT(IN)    :: ATOMICSPECIE
    CHARACTER (LEN=1), INTENT(IN)    :: MANIFOLD
    INTEGER,           INTENT(INOUT) :: INFO

    INTEGER  r,D_F2,P,r_,p_
    DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE:: Energy

    !  write(*,*) atomicspecie, ' alkali ', manifold
    INFO = 4
    CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,MANIFOLD,0.2D1,ID,INFO)
    !------ ALLOCATE NEEDED ARRAYS: Hamiltonian and Lapack
    !write(*,*) total_states_lsi,info
    ALLOCATE(Energy(TOTAL_STATES_LSI))
    ALLOCATE(H_IJ(Total_states_LSI,Total_states_LSI))
    ALLOCATE(U_ZEEMAN(Total_states_LSI,Total_states_LSI))
    ALLOCATE(HAMILTONIAN(Total_states_LSI,Total_states_LSI))
    U_zeeman = 0
    !  IF(INFO.EQ.1 .AND. PRESENT(MANIFOLD)) THEN
    IF(INFO.EQ.1 .AND. MANIFOLD.EQ.'B') THEN
       ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
       ALLOCATE(I_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(I_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(I_z(Total_states_LSI,Total_states_LSI))
       j_x           = 0.0
       j_y           = 0.0
       j_z           = 0.0
       I_x           = 0.0
       I_y           = 0.0
       I_z           = 0.0

       !---------------- Build the angular momentum operators in the JImImJ basis,
       !---------------- in decresing order of m=mI+mJ, with mJ=1/2,-1/2
       CALL I_and_J_representations(j_x,j_y,j_z,I_x,I_y,I_z,L,S,I)

    ELSE IF(INFO.EQ.1 .AND. MANIFOLD.NE.'B') THEN
       ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
       ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
       CALL F_REPRESENTATION(j_x,j_y,j_z,1.0D0*Ftotal)
    END IF
    !  END IF

  END SUBROUTINE FLOQUETINIT_ALKALI
END MODULE FLOQUETINITINTERFACE

SUBROUTINE SETHAMILTONIANCOMPONENTS(ID,NM,NF,MODES_NUM,FIELD,INFO)
  ! ID  tYPE OF ATOM
  ! MODES_NUM, VECTOR. THE SIZE OF THE VECTOR TELL US THE NUMBER OF FREQUENCIES, AND THE VALUE OF EACH COMPONENT INDICATES THE NUMBER OF HARMONICS OF EACH FREQUENCI
  ! FIELDS : IN AND OUTPUT THE MATRICES
  ! INFO

  USE ARRAYS
  USE ATOMIC_PROPERTIES
  USE TYPES
  USE SUBINTERFACE_LAPACK ! write_matrix interface

  IMPLICIT NONE
  INTEGER,                   INTENT(IN)    :: NM,NF
  TYPE(ATOM),                INTENT(IN)    :: ID
  INTEGER,    DIMENSION(NM), INTENT(IN)    :: MODES_NUM
  TYPE(MODE), DIMENSION(NF), INTENT(INOUT) :: FIELD
  INTEGER,                   INTENT(INOUT) :: INFO

  INTEGER m,TOTAL_FREQUENCIES,N_FLOQUET_,KD
  DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: mFs
  DOUBLE PRECISION, DIMENSION(id%d_bare) :: E_ZEEMAN
  DOUBLE PRECISION :: RESONANTrfFREQUENCY

  TOTAL_FREQUENCIES = NF

  SELECT CASE(ID%id_system)
  CASE(3) ! ATOM, BOTH HYPERFINE MANIFOLDS
     U_ZEEMAN = 0.0
     DO m=1,TOTAL_FREQUENCIES
        IF(m.EQ.1) THEN
           FIELD(m)%V = A*(MATMUL(I_x,J_x) - MATMUL(I_y,J_y) + MATMUL(I_z,J_z)) + &
                &       mu_B*(g_J*(FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*J_x  + &
                & DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*J_y  + &
                &                  FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*J_z) + &
                &            (g_I*(FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*I_x  + &
                & DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*I_y  + &
                &                  FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*I_z)))
           FIELD(m)%V = FIELD(m)%V/A
           U_ZEEMAN = FIELD(m)%V
           CALL LAPACK_FULLEIGENVALUES(U_ZEEMAN,SIZE(FIELD(m)%V,1),E_ZEEMAN,INFO) ! FIND THE BASIS OF ZEEMAN STATES
           FIELD(m)%V = MATMUL(TRANSPOSE(CONJG(U_ZEEMAN)),MATMUL(FIELD(m)%V,U_ZEEMAN))
        END IF

        IF(m.GT.1) THEN
           FIELD(m)%V = mu_B*(g_J*(FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*J_x  + &
                & DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*J_y  + &
                &                  FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*J_z) + &
                &            (g_I*(FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*I_x  + &
                & DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*I_y  + &
                &                  FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*I_z)))
           FIELD(m)%V = FIELD(m)%V/A
           FIELD(m)%V = MATMUL(TRANSPOSE(CONJG(U_ZEEMAN)),MATMUL(FIELD(m)%V,U_ZEEMAN))!WRITE THE COUPLINGS IN THE ZEEMAN BASIS
        END IF
     END DO

     KD = SIZE(U_ZEEMAN,1)
     DO m=2,TOTAL_FREQUENCIES-1
        N_FLOQUET_  = MODES_NUM(m)
        KD = KD*(2*N_FLOQUET_+1)
     END DO
     KD = KD + SIZE(U_ZEEMAN,1) - 1

  CASE(7) ! ONE DIMENSIONAL TIGHT BINDING LATTICE

  CASE(8) ! TWO-DIMENSIONAL TIGHT BINDING LATTICE

  CASE DEFAULT ! alkali ATOM with ONE MANIFOLD, QUBIT, SPIN

     U_ZEEMAN = 0.0
     DO m=1,TOTAL_FREQUENCIES
        IF(m.EQ.1) THEN
           FIELD(m)%V =            (FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*J_x  + &
                &  DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*J_y  + &
                FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*J_z)
           U_ZEEMAN   = FIELD(m)%V
           CALL LAPACK_FULLEIGENVALUES(U_ZEEMAN,SIZE(FIELD(m)%V,1),E_ZEEMAN,INFO)
        END IF

        IF(m.GT.1) THEN
           FIELD(m)%V =            (FIELD(m)%X*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_x)*J_x  + &
                &  DCMPLX(0.0,-1.0)*FIELD(m)%Y*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_y)*J_y  + &
                FIELD(m)%Z*EXP(DCMPLX(0.0,1.0)*FIELD(m)%phi_z)*J_z)
           FIELD(m)%V = MATMUL(TRANSPOSE(CONJG(U_ZEEMAN)),MATMUL(FIELD(m)%V,U_ZEEMAN))
           !           write(*,*) m, field(m)%X

        END IF
     END DO
     KD = SIZE(U_ZEEMAN,1)
     DO m=2,TOTAL_FREQUENCIES-1
        N_FLOQUET_  = MODES_NUM(m)
        KD = KD*(2*N_FLOQUET_+1)
     END DO
     KD = KD + SIZE(U_ZEEMAN,1) - 1

  END SELECT

END SUBROUTINE SETHAMILTONIANCOMPONENTS

SUBROUTINE FLOQUETINIT_OLD(ID,jtotal,manifold,atomicspecie)
  ! ATOMICSPECIE: 87Rb,6Li,Cs,41K,qubit,lattice, SPIN
  ! MANIFOLD : "U" UPPER HYPERFINE MANIFOLD, "L" LOWER HYPERFIND MANIFOLD, "B" BOTH
  ! JTOTAL   :  IF ATOMICSPECIE .EQ. SPIN THEN JTOTAL IS THE TOTAL ANGULAR MOMENTUM OF THE SPIN
  !             IF ATOMICSPECIE .EQ. LATTICE, THEN JTOTAL IS THE NUMBER OF SITES

  ! calculate the dimenson of the Hilbert space
  ! initialize all the matrices required for a full Floquet calcuations
  ! Calculate the nuclear, electron and total angular momentum operators

  USE physical_constants ! Standard Module with constants
  USE ATOMIC_PROPERTIES  ! gF, F , etc. factors for several species
  USE subinterface       ! To ubroutines for representation of I and J operators
  USE ARRAYS
  USE SUBINTERFACE_LAPACK
  USE TYPES
  IMPLICIT NONE

  TYPE(ATOM),        INTENT(INOUT)       :: ID
  CHARACTER (LEN=*), INTENT(IN),optional :: ATOMICSPECIE
  DOUBLE PRECISION,  INTENT(IN),optional :: JTOTAL
  CHARACTER (LEN=1), INTENT(IN),optional :: MANIFOLD

  INTEGER  r,D_F2,P,r_,p_,info
  DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE:: Energy

  INFO = 4
  IF( PRESENT(ATOMICSPECIE) .AND. PRESENT(MANIFOLD) .AND. PRESENT(JTOTAL)) THEN
     CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,MANIFOLD,JTOTAL,ID,INFO)
  ELSE IF( PRESENT(ATOMICSPECIE) .AND. PRESENT(JTOTAL)) THEN
     CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,'B',JTOTAL,ID,INFO)
  ELSE IF(PRESENT(ATOMICSPECIE) .AND. PRESENT(MANIFOLD)) THEN
     CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,MANIFOLD,0.2D1,ID,INFO)
  ELSE IF (PRESENT(ATOMICSPECIE)) THEN
     CALL SET_ATOMIC_PARAMETERS(ATOMICSPECIE,'U',0.1D1,ID,INFO)
  END IF

  !------ ALLOCATE NEEDED ARRAYS: Hamiltonian and Lapack

  ALLOCATE(Energy(TOTAL_STATES_LSI))
  ALLOCATE(H_IJ(Total_states_LSI,Total_states_LSI))
  ALLOCATE(U_ZEEMAN(Total_states_LSI,Total_states_LSI))
  ALLOCATE(HAMILTONIAN(Total_states_LSI,Total_states_LSI))

  U_zeeman = 0

  IF(INFO.EQ.1 .AND. PRESENT(MANIFOLD)) THEN
     IF(INFO.EQ.1 .AND. MANIFOLD.EQ.'B') THEN

        ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
        ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
        ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
        ALLOCATE(I_x(Total_states_LSI,Total_states_LSI))
        ALLOCATE(I_y(Total_states_LSI,Total_states_LSI))
        ALLOCATE(I_z(Total_states_LSI,Total_states_LSI))

        j_x           = 0.0
        j_y           = 0.0
        j_z           = 0.0
        I_x           = 0.0
        I_y           = 0.0
        I_z           = 0.0

        !---------------- Build the angular momentum operators in the JImImJ basis,
        !---------------- in decresing order of m=mI+mJ, with mJ=1/2,-1/2
        CALL I_and_J_representations(j_x,j_y,j_z,I_x,I_y,I_z,L,S,I)

     ELSE IF(INFO.EQ.1 .AND. MANIFOLD.NE.'B') THEN
        ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
        ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
        ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
        CALL F_REPRESENTATION(j_x,j_y,j_z,1.0D0*Ftotal)
     END IF
  END IF

  IF(INFO.EQ.2) THEN
     ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
     CALL F_REPRESENTATION(j_x,j_y,j_z,0.05D1)
  ELSE IF(INFO.EQ.3) THEN
     ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
     CALL F_REPRESENTATION(j_x,j_y,j_z,1.0D0*Ftotal)
  ELSE IF(INFO.EQ.4) THEN
  ELSE IF(INFO.EQ.5) THEN
     ALLOCATE(j_x(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_y(Total_states_LSI,Total_states_LSI))
     ALLOCATE(j_z(Total_states_LSI,Total_states_LSI))
  END IF

END SUBROUTINE FLOQUETINIT_OLD


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine dlwqf4 ( noseg  , nobnd  , nosys  , notot  , isys   ,         &
     &                    idt    , conc   , deriv  , volold , bound  ,         &
     &                                      rhs    , diag   , sol    )

!     Deltares - Delft Software Department

!     Created   : Nov. 1996 by Kian Tan

!     Function  : define right hand side of the matrix equation

!     Modified  : July 2008, Leo Postma  : WAQ performance timers
!                 July 2009, Leo Postma  : double precission version

      use timers                         ! WAQ performance timers

      implicit none

!     Arguments           :

!     Kind        Function         Name                  Description

      integer(4), intent(in   ) :: noseg               ! Number of computational volumes
      integer(4), intent(in   ) :: nobnd               ! Number of open boundaries
      integer(4), intent(in   ) :: nosys               ! Number of transported substances
      integer(4), intent(in   ) :: notot               ! Total number of substances
      integer(4), intent(in   ) :: isys                ! This substance
      integer(4), intent(in   ) :: idt                 ! timestep in scu's
      real   (4), intent(in   ) :: conc  (notot,noseg) ! all concentrations
      real   (4), intent(in   ) :: deriv (notot,noseg) ! all derivatives (loads, processes)
      real   (4), intent(in   ) :: volold(noseg)       ! volumes at beginning of time step
      real   (4), intent(in   ) :: bound (nosys,nobnd) ! open boundary concentrations
      real   (8), intent(  out) :: rhs   (noseg+nobnd) ! right hand side of the equation
      real   (8), intent(in   ) :: diag  (noseg+nobnd) ! value of the diagonal
      real   (8), intent(  out) :: sol   (noseg+nobnd) ! initial guess

!     Local declarations

      real   (8) ddt                                   ! 1.0 / time step in double
      integer(4) iseg                                  ! Loop variable

!     The WAQ-timer

      integer(4) ithandl /0/
      if ( timon ) call timstrt ( "dlwqf4", ithandl )

!         set the right hand side, normal part

      ddt = 1.0d00 / idt

      do iseg = 1 , noseg
         rhs(iseg) = deriv(isys,iseg) + volold(iseg)*conc(isys,iseg)*ddt
      enddo

!         set the right hand side, open boundary part

      do iseg = 1, nobnd
         rhs(noseg+iseg) = bound(isys,iseg)
      enddo

!        row scaling

      do iseg = 1, noseg + nobnd
         rhs(iseg) = rhs(iseg) / diag(iseg)
      enddo

!        zero initial guess, try previous concentration for water volumes
!        ( alternatively take zero vector ). Zero initial guess for boundaries.

      sol = 0.0
      do iseg = 1, noseg
         sol(iseg) = conc(isys,iseg) + 0.01
      enddo

      if ( timon ) call timstop ( ithandl )

      return
      end


C$Procedure      ZZGFCOQ ( GF, return coordinate quantity )

      SUBROUTINE ZZGFCOQ ( VECDEF, METHOD, TRGID, ET,
     .                     REF,    ABCORR, OBSID, DREF,
     .                     DVEC,   CRDSYS, CTRID, RE,
     .                     F,      CRDNAM, VALUE, FOUND )

C$ Abstract
C
C     SPICE private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due to the
C     volatile nature of this routine.
C
C     Return the value of a specified coordinate of a vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     GF
C     SPK
C     TIME
C     NAIF_IDS
C     FRAMES
C
C$ Keywords
C
C     GEOMETRY
C     PRIVATE
C     SEARCH
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'gf.inc'
      INCLUDE               'zzgf.inc'

      CHARACTER*(*)         VECDEF
      CHARACTER*(*)         METHOD
      INTEGER               TRGID
      DOUBLE PRECISION      ET
      CHARACTER*(*)         REF
      CHARACTER*(*)         ABCORR
      INTEGER               OBSID
      CHARACTER*(*)         DREF
      DOUBLE PRECISION      DVEC   ( 3 )
      CHARACTER*(*)         CRDSYS
      INTEGER               CTRID
      DOUBLE PRECISION      RE
      DOUBLE PRECISION      F
      CHARACTER*(*)         CRDNAM
      DOUBLE PRECISION      VALUE
      LOGICAL               FOUND

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     VECDEF     I   Vector definition.
C     METHOD     I   Computation method.
C     TRGID      I   Target ID code.
C     ET         I   Computation epoch.
C     REF        I   Reference frame name.
C     ABCORR     I   Aberration correction.
C     OBSID      I   Observer ID code.
C     DREF       I   Reference frame of ray's direction vector.
C     DVEC       I   Ray's direction vector.
C     CRDSYS     I   Coordinate system name.
C     CTRID      I   Frame center ID code.
C     RE         I   Equatorial radius of central body.
C     F          I   Flattening coefficient of central body.
C     CRDNAM     I   Coordinate name.
C     VALUE      O   Coordinate value.
C     FOUND      O   Flag indicating if coordinate was computed.
C
C$ Detailed_Input
C
C
C     VECDEF     Every coordinate computed by this routine is a
C                function of an underlying vector. VECDEF is a short
C                string describing the means by which the vector of
C                interest is defined. Only parameters from the Fortran
C                INCLUDE file zzgf.inc should be used. Parameter names
C                and meanings are:
C
C                   POSDEF               Vector is position of
C                                        target relative to observer.
C
C                   SOBDEF               Vector is sub-observer
C                                        point on target body.  Vector
C                                        points from target body
C                                        center to sub-observer point.
C                                        The target must be an extended
C                                        body modeled as a triaxial
C                                        ellipsoid.
C
C                   SINDEF               Vector is ray-surface intercept
C                                        point on target body. Vector
C                                        points from target body
C                                        center to sub-observer point.
C                                        The target must be an extended
C                                        body modeled as a triaxial
C                                        ellipsoid.
C
C                Case, leading and trailing blanks ARE significant
C                in the string VECDEF.
C
C
C     METHOD     is a string specifying the computational method
C                applicable to the vector of interest. When VECDEF
C                is the parameter
C
C                   SOBDEF
C
C                METHOD should be set to one of the values accepted
C                by the SPICELIB routine SUBPNT.
C
C                When VECDEF is the parameter
C
C                   SINDEF
C
C                METHOD should be set to one of the values accepted
C                by the SPICELIB routine SINCPT.
C
C                METHOD is ignored if VECDEF is set to
C
C                   POSDEF
C
C                Case, leading and trailing blanks are not significant
C                in the string METHOD.
C
C
C     TRGID      is the NAIF ID code of the target object.
C
C
C     ET         is the time, expressed as ephemeris seconds past J2000
C                TDB, at which the specified coordinate is to be
C                computed.
C
C
C     REF        is the name of the reference frame relative to which
C                the vector of interest is specified.  The specified
C                condition applies to the specified coordinate of
C                of this vector in frame REF.
C
C                When geodetic or planetographic coordinates are used,
C                the reference ellipsoid is assumed to be that
C                associated with the central body of the frame
C                designated by REF. In this case, the central body of
C                the frame must be an extended body.
C
C                Case, leading and trailing blanks are not significant
C                in the string REF.
C
C
C     ABCORR     indicates the aberration corrections to be applied to
C                the state of the target body to account for one-way
C                light time and stellar aberration.  The orientation
C                of the target body will also be corrected for one-way
C                light time when light time corrections are requested.
C
C                Supported aberration correction options for
C                observation (case where radiation is received by
C                observer at ET) are:
C
C                   NONE           No correction.
C                   LT             Light time only.
C                   LT+S           Light time and stellar aberration.
C                   CN             Converged Newtonian (CN) light time.
C                   CN+S           CN light time and stellar aberration.
C
C                Supported aberration correction options for
C                transmission (case where radiation is emitted from
C                observer at ET) are:
C
C                   XLT            Light time only.
C                   XLT+S          Light time and stellar aberration.
C                   XCN            Converged Newtonian (CN) light time.
C                   XCN+S          CN light time and stellar aberration.
C
C                For detailed information, see the geometry finder
C                required reading, gf.req.  Also see the header of
C                SPKEZR, which contains a detailed discussion of
C                aberration corrections.
C
C                Case, leading and trailing blanks are not significant
C                in the string ABCORR.
C
C
C     OBSID      is the NAIF ID code of the observer.
C
C
C     DREF       is the name of the reference frame relative to which a
C                ray's direction vector is expressed. This may be any
C                frame supported by the SPICE system, including
C                built-in frames (documented in the Frames Required
C                Reading) and frames defined by a loaded frame kernel
C                (FK). The string DREF is case-insensitive, and leading
C                and trailing blanks in FIXREF are not significant.
C
C                When DREF designates a non-inertial frame, the
C                orientation of the frame is evaluated at an epoch
C                dependent on the frame's center and, if the center is
C                not the observer, on the selected aberration
C                correction. See the description of the direction
C                vector DVEC for details.
C
C
C     DVEC       Ray direction vector emanating from the observer. The
C                intercept with the target body's surface of the ray
C                defined by the observer and DVEC is sought.
C
C                DVEC is specified relative to the reference frame
C                designated by DREF.
C
C                Non-inertial reference frames are treated as follows:
C                if the center of the frame is at the observer's
C                location, the frame is evaluated at ET. If the frame's
C                center is located elsewhere, then letting LTCENT be
C                the one-way light time between the observer and the
C                central body associated with the frame, the
C                orientation of the frame is evaluated at ET-LTCENT,
C                ET+LTCENT, or ET depending on whether the requested
C                aberration correction is, respectively, for received
C                radiation, transmitted radiation, or is omitted.
C                LTCENT is computed using the method indicated by
C                ABCORR.
C
C
C     CRDSYS     is the name of the coordinate system to which the
C                coordinate of interest belongs. Allowed values are
C                those defined in the GF Fortran INCLUDE file
C
C                   zzgf.inc.
C
C                Case, leading and trailing blanks ARE significant
C                in the string CRDSYS.
C
C
C     CTRID      is the NAIF ID code of the input frame REF's center.
C
C
C     RE         is the equatorial radius associated with the body
C                designated by CTRID. RE is used only when the
C                coordinate system is GEOSYS or PGRSYS; otherwise
C                RE may be set to 0.D0.
C
C     F          is the flattening coefficient associated with the body
C                designated by CTRID. RE is used only when the
C                coordinate system is GEOSYS or PGRSYS; otherwise RE
C                may be set to 0.D0.
C
C
C     CRDNAM     is the name of the coordinate of interest:  this is
C                the coordinate to which the specified condition
C                applies.  The set of coordinate names is a function of
C                the coordinate system. Allowed values are those
C                defined in the GF Fortran INCLUDE file
C
C                   zzgf.inc.
C
C                Case, leading and trailing blanks ARE significant
C                in the string CRDNAM.
C
C
C$ Detailed_Output
C
C     VALUE     is the specified coordinate, evaluated at the epoch ET.
C               Coordinates having dimensions of length have units of
C               km. Coordinates having angular dimensions have units of
C               radians.
C
C               VALUE is defined if and only if the output argument
C               FOUND is set to .TRUE.
C
C
C     FOUND     is a logical flag indicating whether the requested
C               coordinate could be computed. FOUND is set to .FALSE.
C               if and only if the vector definition is SINDEF and
C               either
C
C                  - no surface intercept is found
C
C                  - the velocity of the surface intercept is not
C                    computable
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the vector definition VECDEF is not recognized,
C         the error SPICE(NOTSUPPORTED) is signaled.
C
C     2)  If the vector definition is either SOBDEF or SINDEF
C         and the computation method METHOD is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     3)  If the aberration correction ABCORR is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     4)  If the coordinate system name CRDSYS is not recognized,
C         the error SPICE(NOTSUPPORTED) is signaled.
C
C     5)  If the coordinate name CRDNAM is not recognized,
C         the error SPICE(NOTSUPPORTED) is signaled.
C
C     6)  If the frame REF is not recognized by the frames subsystem,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     7)  If VECDEF calls for a computation involving a target surface
C         point and the radii defining the reference ellipsoid
C         associated with the target body are not available in the
C         kernel pool, the error will be diagnosed by routines in the
C         call tree of this routine.
C
C     8)  If VECDEF calls for a computation involving a target surface
C         point and the name and ID code of the frame associated with
C         the target body is not available from the frame subsystem,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     9)  If ephemeris data are required but not available to compute
C         the state of the target, the coordinate frame REF's center,
C         or the input ray's frame DREF's center relative to the
C         observer, the error will be diagnosed by routines in the call
C         tree of this routine.
C
C     10) If orientation data for the frame REF are not available,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     11) If orientation data for the frame DREF are required but
C         not available, the error will be diagnosed by routines in the
C         call tree of this routine.
C
C$ Files
C
C     This routine doesn't directly participate in SPICE kernel loading
C     or unloading.  However, a variety of SPICE kernels must be loaded
C     in order for this routine to work:
C
C        - Since all coordinate computations supported by this routine
C          depend on observer-target vectors, at a minimum, SPK files
C          providing ephemeris data enabling computation of these
C          vectors are required.
C
C        - If non-inertial reference frames are used, then PCK
C          files, frame kernels, C-kernels, and SCLK kernels may be
C          needed.
C
C        - If the coordinate of interest is defined in terms of a target
C          surface point, then (currently) a PCK providing radii for a
C          triaxial shape model must be loaded.
C
C        - If geodetic or planetographic coordinates are used, then a
C          PCK providing radii for a triaxial shape model must be
C          loaded.
C
C     See the Files section of GFEVNT's header for further information.
C
C$ Particulars
C
C     This routine is used by the GF coordinate utility routines in
C     order to solve for time windows on which specified mathematical
C     conditions involving coordinates are satisfied.
C
C$ Examples
C
C     See ZZGFCOU.
C
C$ Restrictions
C
C     1)  The interface and functionality of this set of routines may
C         change without notice.  These routines should be called only
C         by SPICELIB routines.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0 12-MAY-2009 (NJB)
C
C        Upgraded to support targets and observers having
C        no names associated with their ID codes.
C
C-    SPICELIB Version 1.0.0 05-MAR-2009 (NJB)
C
C-&

C$ Index_Entries
C
C     compute coordinates of a vector
C
C-&

C
C     SPICELIB functions
C
      INTEGER               ISRCHC

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               BDNMLN
      PARAMETER           ( BDNMLN = 36 )

      INTEGER               CRDLEN
      PARAMETER           ( CRDLEN = 32 )

      INTEGER               NSYS
      PARAMETER           ( NSYS   = 7 )

C
C     Local variables
C
      CHARACTER*(CRDLEN)    CRDNMS ( 3, NSYS )
      CHARACTER*(BDNMLN)    CTRNAM
      CHARACTER*(BDNMLN)    OBSNAM
      CHARACTER*(CRDLEN)    SYSNMS (    NSYS )
      CHARACTER*(CRDLEN)    SYSNAM
      CHARACTER*(BDNMLN)    TRGNAM

      DOUBLE PRECISION      COORDS ( 3 )
      DOUBLE PRECISION      LT
      DOUBLE PRECISION      POS    ( 3 )
      DOUBLE PRECISION      TRGEPC
      DOUBLE PRECISION      SRFVEC ( 3 )

      INTEGER               CRDIDX
      INTEGER               PRVCTR
      INTEGER               PRVOBS
      INTEGER               PRVTRG
      INTEGER               SYSIDX

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  CRDNMS
      SAVE                  CTRNAM
      SAVE                  FIRST
      SAVE                  OBSNAM
      SAVE                  PRVCTR
      SAVE                  PRVOBS
      SAVE                  PRVTRG
      SAVE                  SYSNMS
      SAVE                  TRGNAM

C
C     Initial values
C
      DATA                  FIRST / .TRUE. /
C
C     The Ith coordinate system in the array SYSNMS has coordinates
C     in the Ith row of the array CRDNMS. This association must be
C     preserved when this routine is updated.
C
      DATA                  SYSNMS /  RECSYS,
     .                                LATSYS,
     .                                RADSYS,
     .                                SPHSYS,
     .                                CYLSYS,
     .                                GEOSYS,
     .                                PGRSYS  /

C
C     The order of the coordinate names in the Ith row of this array
C     matches the order of the outputs of the corresponding
C     SPICELIB routine REC*, which maps a Cartesian vector to
C     the Ith coordinate system in the array SYSNMS. Again, this
C     order must be preserved.
C
      DATA                  CRDNMS /  XCRD,     YCRD,     ZCRD,
     .                                RADCRD,   LONCRD,   LATCRD,
     .                                RNGCRD,   RACRD,    DECCRD,
     .                                RADCRD,   CLTCRD,   LONCRD,
     .                                RADCRD,   LONCRD,   ZCRD,
     .                                LONCRD,   LATCRD,   ALTCRD,
     .                                LONCRD,   LATCRD,   ALTCRD  /

      DATA                  PRVCTR /  0 /
      DATA                  PRVOBS /  0 /
      DATA                  PRVTRG /  0 /

      DATA                  OBSNAM / ' ' /
      DATA                  TRGNAM / ' ' /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZGFCOQ' )

C
C     No result was found yet.
C
      FOUND = .FALSE.

C
C     Find the index of the coordinate system name in the list of
C     supported names.
C
      SYSIDX = ISRCHC ( CRDSYS, NSYS, SYSNMS )

      IF ( SYSIDX .EQ. 0 ) THEN
C
C        We don't recognize this system name.
C
         CALL SETMSG ( 'The coordinate system # is not supported.' )
         CALL ERRCH  ( '#',  CRDSYS                                )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                       )
         CALL CHKOUT ( 'ZZGFCOQ'                                   )
         RETURN

      END IF

      SYSNAM = SYSNMS(SYSIDX)

C
C     Find the index of the coordinate name in the list of
C     supported names.
C
      CRDIDX = ISRCHC ( CRDNAM, 3, CRDNMS(1,SYSIDX) )

      IF ( CRDIDX .EQ. 0 ) THEN
C
C        We don't recognize this coordinate name.
C
         CALL SETMSG ( 'The coordinate name # belonging to the '  //
     .                 'coordinate system # is not recognized.'   )
         CALL ERRCH  ( '#',  CRDNAM                               )
         CALL ERRCH  ( '#',  CRDSYS                               )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                      )
         CALL CHKOUT ( 'ZZGFCOQ'                                  )
         RETURN

      END IF

C
C     Look up the target and observer names if these will be
C     needed. The SUBPNT and SINCPT interfaces require them.
C     The RECPGR interface requires the frame center ID code
C     as well.
C
      IF (      ( VECDEF .EQ. SOBDEF )
     .     .OR. ( VECDEF .EQ. SINDEF )
     .     .OR. ( SYSNAM .EQ. PGRSYS )  ) THEN

         IF (  FIRST  .OR. ( TRGID .NE. PRVTRG )  ) THEN

            CALL BODC2S ( TRGID, TRGNAM )

            PRVTRG = TRGID

         END IF

         IF (  FIRST  .OR. ( OBSID .NE. PRVOBS )  ) THEN

            CALL BODC2S ( OBSID, OBSNAM )

            PRVOBS = OBSID

         END IF

         IF (  FIRST  .OR. ( CTRID .NE. PRVCTR )  ) THEN

            CALL BODC2S ( CTRID, CTRNAM )

            PRVCTR = CTRID

         END IF

         FIRST = .FALSE.

      END IF

      IF ( VECDEF .EQ. POSDEF  ) THEN
C
C        Find the observer-target position vector.
C
         CALL SPKEZP ( TRGID, ET, REF, ABCORR, OBSID, POS, LT )

      ELSE IF ( VECDEF .EQ. SOBDEF ) THEN
C
C        The caller has requested a sub-observer point coordinate
C        computation.
C
         CALL SUBPNT ( METHOD, TRGNAM, ET,  REF,
     .                 ABCORR, OBSNAM, POS, TRGEPC, SRFVEC )

      ELSE IF ( VECDEF .EQ. SINDEF ) THEN
C
C        The caller has requested a surface intercept point coordinate
C        computation.
C
         CALL SINCPT ( METHOD,  TRGNAM, ET,     REF,
     .                 ABCORR,  OBSNAM, DREF,   DVEC,
     .                 POS,     TRGEPC, SRFVEC, FOUND  )

C
C        Without an intercept, there's nothing left to do here.
C
         IF ( .NOT. FOUND ) THEN
            CALL CHKOUT ( 'ZZGFCOQ' )
            RETURN
         END IF

      ELSE

         CALL SETMSG ( 'The coordinate quantity # is not recognized.' )
         CALL ERRCH  ( '#',  VECDEF                                   )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                          )
         CALL CHKOUT ( 'ZZGFCOQ'                                      )
         RETURN

      END IF

C
C     If we already encountered an error while trying to compute
C     the vector of interest, return now.
C
      IF (  FAILED() ) THEN
          CALL CHKOUT (  'ZZGFCOQ' )
          RETURN
      END IF

C
C     At this point we assume the vector whose coordinate is
C     to be computed resides in POS. Convert POS to the
C     specified coordinate system.
C
      IF ( SYSNAM .EQ. RECSYS ) THEN
C
C        No conversion needed for rectangular coordinates.
C
         CALL MOVED ( POS, 3, COORDS )

      ELSE IF ( SYSNAM .EQ. LATSYS ) THEN

         CALL RECLAT ( POS, COORDS(1), COORDS(2), COORDS(3) )

      ELSE IF ( SYSNAM .EQ. RADSYS ) THEN

         CALL RECRAD ( POS, COORDS(1), COORDS(2), COORDS(3) )

      ELSE IF ( SYSNAM .EQ. SPHSYS ) THEN

         CALL RECSPH ( POS, COORDS(1), COORDS(2), COORDS(3) )

      ELSE IF ( SYSNAM .EQ. CYLSYS ) THEN

         CALL RECCYL ( POS, COORDS(1), COORDS(2), COORDS(3) )

      ELSE IF ( SYSNAM .EQ. GEOSYS ) THEN

         CALL RECGEO ( POS, RE, F, COORDS(1), COORDS(2), COORDS(3) )

      ELSE IF ( SYSNAM .EQ. PGRSYS ) THEN

         CALL RECPGR ( CTRNAM,    POS,       RE,       F,
     .                 COORDS(1), COORDS(2), COORDS(3)    )

      ELSE
C
C        We should never arrive here.
C
         CALL SETMSG ( 'The coordinate system # is not supported.' )
         CALL ERRCH  ( '#',  CRDSYS                                )
         CALL SIGERR ( 'SPICE(BUG)'                                )
         CALL CHKOUT ( 'ZZGFCOQ'                                   )
         RETURN

      END IF

C
C     Set the return value.
C
C     CRDIDX indicates the index of the coordinate of interest
C     in the list of coordinates for the input coordinate system.
C
      VALUE = COORDS(CRDIDX)

C
C     Having made it this far means the result was found.
C
      FOUND = .TRUE.

      CALL CHKOUT  ( 'ZZGFCOQ' )
      RETURN
      END


	SUBROUTINE RA_DECD  ( irpntr, coun, asoflg, maxcld, ighr,
     +			      cldtyp, cldhgt, ncld, vsby, wcod, wnum,
     +			      pres, tmpf, dwpf, sknt, drct, gust,
     +			      alti, p03d, p03i, p06i, hsun, csyl,
     +			      csym, csyh, snow, weqs, t06x, t12x,
     +			      t24x, tmdx, t06n, t12n, t24n, tmdn,
     +			      p24i, iret )
C************************************************************************
C* RA_DECD								*
C*									*
C* This subroutine decodes a surface airways report.  RA_GFLD must	*
C* be called before this subroutine is called.  IRPNTR must point	*
C* to the first field after the header.					*
C*									*
C* RA_DECD  ( IRPNTR, COUN, ASOFLG, MAXCLD, IGHR, CLDTYP, CLDHGT, NCLD, *
C*	      VSBY, WCOD, WNUM, PRES, TMPF, DWPF, SKNT, DRCT, GUST, 	*
C*            ALTI, P03D, P03I, P06I, HSUN, CSYL, CSYM, CSYH, SNOW, 	*
C*	      WEQS, T06X, T12X, T24X, TMDX, T06N, T12N, T24N, TMDN, 	*
C*	      P24I, IRET )						*
C*									*
C* Input parameters:							*
C*	IRPNTR		INTEGER		First field after header	*
C*	COUN		CHAR*		Country name			*
C*	ASOFLG		LOGICAL		ASOS station flag		*
C*	MAXCLD		INTEGER		Maximum number of clouds	*
C*	IGHR		INTEGER		Integer GEMPAK report hour	*
C*									*
C* Output parameters:					                *
C*	CLDTYP (NCLD)	REAL		GEMPAK cloud numeric types	*
C*	CLDHGT (NCLD)	REAL		Cloud heights			*
C*	NCLD		INTEGER		Number of cloud reports		*
C*	VSBY		REAL		Visibility in miles		*
C*	WCOD		CHAR*		GEMPAK weather code		*
C*	WNUM		REAL		GEMPAK weather number		*
C*	PRES		REAL		Pressure in millibars		*
C*	TMPF		REAL		Temperature in F		*
C*	DWPF		REAL		Dewpoint temp in F		*
C*	SKNT		REAL		Wind speed in knots		*
C*	DRCT		REAL		Wind direction in degrees	*
C*	GUST		REAL		Wind gusts in knots		*
C*	ALTI		REAL		Altimeter in inches		*
C*	P03D		REAL		Pres. tend (sym+amnt) tenths mb	*
C*	P03I		REAL		3-hr precip in inches		*
C*	P06I		REAL		6-hr precip in inches		*
C*	HSUN		REAL		Minutes of sunshine		*
C*	CSYL		REAL		Low level cloud symbol		*
C*	CSYM		REAL		Mid level cloud symbol		*
C*	CSYH		REAL		High level cloud symbol		*
C*	SNOW		REAL		Snow accumulation in inches	*
C*	WEQS		REAL		Water equiv of snow depth inches*
C*	T06X		REAL		6 Hr Max temperature in F 	*
C*	T12X		REAL		12 Hr Max temperature in F	*
C*	T24X		REAL		24 Hr Max temperature in F	*
C*	TMDX		REAL		Prev day max temperature in F	*
C*	T06N		REAL		6 Hr Min temperature in F 	*
C*	T12N		REAL		12 Hr Min temperature in F	*
C*	T24N		REAL		24 Hr Min temperature in F	*
C*	TMDN		REAL		Prev day min temperature in F	*
C*	P24I		REAL		24-hr precip in in		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -4 = report not decoded	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/89	GEMPAK 5				*
C* J. Walker/FSU	11/90	Added ceiling codes			*
C* J. Walker/FSU	12/90	Added additive data			*
C* J. Whistler/SSAI	 2/91	Cleaned up FSU changes			*
C* P. Bruehl/Unidata	 4/93	Added ptsy pres. tendency symbol	*
C* P. Bruehl/Unidata		Fixed pt03 to be real p03d(sym+amnt)	*
C* P. Bruehl/Unidata	2/94	Added synflg for 0,6,12,18Z report times*
C* P. Bruehl/Unidata	2/94	Added cloud symbols			*
C* P. Bruehl/Unidata   10/94    Fixed reset of snow & cl.sym. to -9999	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'racmn.cmn'
C*
        INTEGER         remain
	REAL		cldhgt (*), cldtyp (*)
	CHARACTER*(*)	wcod, coun
        LOGICAL         sunflg, synflg, asoflg
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	synflg = .false.
C
C*	Get the winds.
C
	CALL RA_WIND ( irpntr, sknt, drct, gust, ipwbef, ipwaft, iret )
C
C*	Decode pressure, temperature, dewpoint and altimeter.
C
	CALL RA_PTDA  ( irpntr, ipwbef, ipwaft, iptbef, ipaaft, pres,
     +			tmpf, dwpf, alti, ier )
C
C*	Convert Canadian station temperatures from C to F.
C
	IF  ( ( coun .ne. 'US' ) .and. ( coun .ne. 'UE' ) .and.
     +	      ( coun .ne. 'UM' ) .and. ( coun .ne. 'UW' ) .and.
     +	      ( coun .ne. 'AK' ) .and. ( coun .ne. 'HW' ) )  THEN
	    tmpf = PR_TMCF ( tmpf )
	    dwpf = PR_TMCF ( dwpf )
	END IF
C
C*	Get the cloud information.
C
	CALL RA_CLDS  ( irpntr, iptbef, maxcld, ipcaft, cldtyp, cldhgt,
     +			ncld, ier )
C
C*	Get the visibility and weather.
C
	CALL RA_VSBY  ( ipcaft, iptbef, ipvaft, vsby, ier )
	CALL RA_WTHR  ( ipvaft, iptbef, wcod, wnum, ier )
C
C*      Check to see if this is 3 hour report. If so check for
C*	extra data.
C
	remain = MOD (ighr,3)
	IF ( ( ( remain .eq. 0 ) .or. ( ighr .eq. 0 ) .or.
     +	       ( ighr.eq.8 ) ) .and. ( coun .eq. 'US' ) ) THEN
C
C*	    Set synflg for main synoptic hours of 0, 6, 12, 18 Z
C
	    IF ( ( ighr .eq.  0 ) .or. ( ighr .eq. 6 ) .or.
     +		 ( ighr .eq. 12 ) .or. ( ighr .eq. 18 ) )
     +		synflg = .true.
C
C*          Get the data that comes after the remarks (pressure
C*          tendency, precipitation(3-hr & 24-hr), max/min
C*          temp, snowfall accumulation, and minutes of sunshine)
C
	    CALL RA_PTND  ( ipaaft, synflg, asoflg, ipnaft, p03d,
     +			    p03i, p06i, hsun, sunflg, ier )
	    IF  ( sunflg )  THEN
C
C*		If sunshine data is present, nothing else will be
C*		so skip over code
C
		snow = RMISSD
		weqs = RMISSD
		tmdx = RMISSD
		t06x = RMISSD
		t12x = RMISSD
		t24x = RMISSD
		tmdn = RMISSD
		t06n = RMISSD
		t12n = RMISSD
		t24n = RMISSD
		p24i = RMISSD
		csyl = RMISSD
		csym = RMISSD
		csyh = RMISSD
	    ELSE
C
C*	    Keep going for more data
C
		IF  ( .not. asoflg )  THEN
		    CALL RA_CSYB  ( ipnaft, ipoaft, csyl, csym, csyh,
     +				    ier )
		    CALL RA_SNOW  ( ipoaft, ipnaft, snow, weqs, ier )
                ELSE
                   snow = RMISSD
                   weqs = RMISSD
                   csyl = RMISSD
                   csym = RMISSD
                   csyh = RMISSD
		ENDIF
		CALL RA_TMPX  ( ipnaft, ighr, asoflg, ipxaft,
     +				t06x, t12x, t24x, tmdx,
     +				t06n, t12n, t24n, tmdn, ier )
		CALL RA_P24I  ( ipxaft, asoflg, p24i, ier )
C
C*		Check for encoded temps that correspond to max/min
C*		temps below 0F or above 100F. These are encoded as
C*		thhx+100 and thhx-100, respectivly.
C*		Examples: -15 is reported as -15 + 100 = 85;
C*			  105 as 105 - 100 = 5.
C*		Test for this by seeing if the reported max/min temp
C*		differs from the current temp by more than 50. If so
C*		correct it.
C
		IF  ( .not. asoflg )  THEN
C
		    isign = 1
		    IF  ( ( .not. ERMISS ( tmpf ) ) .and.
     +			  ( tmpf .lt. 50. ) )
     +			isign = -1
C
		    IF  ( ( .not. ERMISS ( t12x ) ) .and.
     +			  ( ABS ( tmpf - t12x ) .gt. 50. ) )
     +			t12x = t12x + isign * 100.
C
		    IF  ( ( .not. ERMISS ( tmdx ) ) .and.
     +			  ( ABS ( tmpf - tmdx ) .gt. 50. ) )
     +			tmdx = tmdx + isign * 100.
C
		    IF  ( ( .not. ERMISS ( t24x ) ) .and.
     +			  ( ABS ( tmpf - t24x ) .gt. 50. ) )
     +			t24x = t24x + isign * 100.
C
		    IF  ( ( .not. ERMISS ( t12n ) ) .and.
     +			  ( ABS ( tmpf - t12n ) .gt. 50. ) )
     +			t12n = t12n + isign * 100.
C
		    IF  ( ( .not. ERMISS ( t24n ) ) .and.
     +			  ( ABS ( tmpf - t24n ) .gt. 50. ) )
     +			t24n = t24n + isign * 100.
C
		ENDIF
	    ENDIF
	ELSE
C
C*	    Not a three hour report; so no more data
C
	    p03d = RMISSD
	    p03i = RMISSD
	    p06i = RMISSD
	    snow = RMISSD
	    weqs = RMISSD
	    hsun = RMISSD
	    t06x = RMISSD
	    t12x = RMISSD
	    t24x = RMISSD
	    tmdx = RMISSD
	    t06n = RMISSD
	    t12n = RMISSD
	    t24n = RMISSD
	    tmdn = RMISSD
	    p24i = RMISSD
	    csyl = RMISSD
	    csym = RMISSD
	    csyh = RMISSD
	END IF
C
C*	If there is no information other than winds, return an error.
C
	IF  ( ( .not. ERMISS (tmpf) ) .or. ( .not. ERMISS (dwpf) ) .or.
     +	      ( .not. ERMISS (pres) ) .or. ( .not. ERMISS (vsby) ) .or.
     +	      ( .not. ERMISS (alti) ) .or. ( ncld .gt. 0 ) )  THEN
C*
	ELSE
	    iret = -5
	END IF
C*
	RETURN
	END