      SUBROUTINE LWP_DRIVER
     &          (begin_file)

c***********************************************************************

c     Routine to processed presegmented path parameters

c***********************************************************************

c  Change history:

c     10 Nov 93     Do the restart of MF using IEXACT=1.

c     30 Jun 94     Drop END_FILE from argument list.

c     14 Nov 94     Added subroutine MF_GET_MC to calculate mode
c                   constants when SW fails at the starting segment.

c     13 Dec 94     Added specification for PRFL_FILE.

c     26 Sep 95     Changed all PRINTs to WRITE(6)s.

c     21 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c     08 Feb 99     When we want to continue using the original
c                   solutions from MF_DRIVER, we must recalculate
c                   them because the list may have been modified
c                   by SW_STEP.

c*******************!***************************************************

c     Sign convention: + for West and North, - for East and South

c     LWPC parameters
      include      'lwpc_lun.cmn'

      parameter    (mxeigen=50,mxsgmnt=201)

      character*  8 archive,prgm_id
      character* 20 xmtr_id,path_id
      character* 40 prfl_id
      character* 80 case_id
      character*120 file_id
      integer       pflag,pindex
      real     *  4 freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht

      common/lwpc_in/
     &              archive,file_id(3),prgm_id,
     &              case_id,prfl_id,xmtr_id,path_id,
     &              freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht,pindex

      real     *  4 ranger,rangei,atnmax,lub,h
      complex  *  8 eigen

      common/lwpc_mf/
     &              ranger(2),rangei(2),atnmax,lub,h,
     &              eigen(mxeigen),nreigen

      real     *  4 hten,algen,htnu,algnu,
     &              charge,ratiom,select_hgts,hgts

      common/lwpc_pr/
     &              hten(51),algen(51,3),nrhten,ihten,
     &              htnu(51),algnu(51,3),nrhtnu,ihtnu,
     &              charge(3),ratiom(3),nrspec,lu_prf,
     &              select_hgts(2),hgts(3)

      common/mf_flag/
     &              iexact,iovflo,kexact,lowg,nodivd,noevct,
     &              nofinl,nointg,nomesh,notlin

      common/mf_sw_1/
     &              dst(mxsgmnt),xla(mxsgmnt),xlo(mxsgmnt),
     &              azm(mxsgmnt),xdp(mxsgmnt),fld(mxsgmnt),
     &              sgm(mxsgmnt),eps(mxsgmnt),ncd(mxsgmnt),
     &              bta(mxsgmnt),hpr(mxsgmnt),npr(mxsgmnt),
     &              num(mxsgmnt),nrsgmnt

      complex  *  8 save_tp,save_capt,save_fofr

      common/mf_sw_2/
     &              save_tp  (mxsgmnt,  mxeigen),
     &              save_capt(mxsgmnt,4,mxeigen),
     &              save_fofr(mxsgmnt,  mxeigen)

      integer       print_swg
      real     *  4 drmin,drmax

      common/sw_path/
     &              drmin,drmax,mdir,lostm,lx,print_swg

      integer       rpoly
      real     *  4 dtheta,tol,deigen,thtinc,ftol,alpha,prec

      common/sw_wgin/
     &              dtheta(2),tol(2),deigen(2),
     &              thtinc,ftol,maxitr,alpha,prec,rpoly,nrtlst

      complex  *  8 tp,capt,fofr

      common/sw_wgou/
     &              tp(mxeigen),capt(4,mxeigen),fofr(mxeigen),lu_mds

      character*120 prfl_file
      logical       begin_file
      integer       month,day,year,UT,prev_index

c intrp=0 --- normal (no interpolation)
c      =1 --- interpolating between points on the path
c      =2 --- final interpolation interval

c lostm=0 --- no trouble with modes
c      =1 --- all modes found but one or more changed significantly
c             from the extrapolated values
c      =2 --- dropped a mode in SW_WVGD or SW_EXTRAP; try to back up
c      =3 --- dropped a mode in SW_WVGD or SW_EXTRAP; skip segment
c      =4 --- dropped a mode in SW_WVGD or SW_EXTRAP; restart with MF
c      =5 --- distance change is too large;           restart with MF

c pflag=0 --- non-exponential profile on whole path
c      =1 ---     exponential profile on whole path
c      =2 ---     exponential profiles for all day
c      =3 ---     exponential profiles for all night
c      =4 ---     exponential profiles for a specific date and time
c      =5,7,9 non-exponential profiles at each point
c      =6,8,10    exponential profiles at each point

Change: 10 Nov 93: Save current value of flags
      iexact_sav=iexact
      irpoly_sav=rpoly

      nsgmnt0=1
      prev_index=0
      do while (nsgmnt0 .le. nrsgmnt)

         nsgmnt=nsgmnt0
         do while (nsgmnt .le. nrsgmnt)

            rho   =dst(nsgmnt)
            lat   =xla(nsgmnt)
            lon   =xlo(nsgmnt)
            azim  =azm(nsgmnt)
            dip   =xdp(nsgmnt)
            bfield=fld(nsgmnt)
            sigma =sgm(nsgmnt)
            epsr  =eps(nsgmnt)
            beta  =bta(nsgmnt)
            hprime=hpr(nsgmnt)
            pindex=npr(nsgmnt)

            if (pflag .eq. 5 .or. pflag .eq. 7 .or. pflag .eq. 9) then

c              Get position dependent tablular profile
               call PRFL_SPECIFICATION
     &             (.false.,print_swg,
     &              prfl_file,prfl_id,pflag,
     &              freq,month,day,year,UT,
     &              lat,lon,rho,dip,zenith,
     &              hpr_mid,beta,hprime,pindex)
            else
     &      if (pindex .ne. prev_index) then

c              Get new profile
               call PRFL_EXP (beta,hprime)
               call PRFL_HGTS (print_swg)
               prev_index=pindex
            end if

            if (mdir .eq. 1) then

c              Reverse azim if for xmtr deployment
               azim=azim-180.
               if (azim .lt.   0.) then
                  azim=azim+360.
               else
     &         if (azim .gt. 360.) then
                  azim=azim-360.
               end if
            end if

            if (print_swg .gt. 0)

     &         write(lwpcLOG_lun,
     &             '(/''Propagation path parameters:''/
     &                ''  rho    lat     lon'',
     &                ''   azim    dip  bfield'',
     &                ''   sigma  epsr  beta   h''''''/
     &                f6.0,f7.2,f8.2,2f7.2,f7.4,
     &                1pe9.1,0pf5.1,2f6.2)')
     &                rho,lat,lon,azim,dip,bfield,
     &                sigma,epsr,beta,hprime

            if (nsgmnt .eq. nsgmnt0) then

c              Initialize extrapolation
               lx=0
               rho0=rho

c              Get starting solutions
               call MF_DRIVER

               if (print_swg .gt. 0)

     &            write(lwpcLOG_lun,
     &                '(''Output from MF_DRIVER:''/(8f9.4))')
     &                 (eigen(j),j=1,nreigen)

               if (nreigen .lt. mxeigen) eigen(nreigen+1)=(0.,0.)

cxx               tol(1)=lub
cxx               tol(2)=lub
cxx               dtheta(1)=lub*2.
cxx               dtheta(2)=lub*2.
cxx               thtinc=lub*8.
cxx
cxxChange: 06 Feb 94
cxxc       Ensure that SW uses the same tolerance for duplicate EIGENs
cxxc       as used by MF.
cxx               deigen(1)=1.
cxx               deigen(2)=1.
cxx               do j=1,nreigen-1
cxx                  eigenjr= REAL(eigen(j))
cxx                  eigenri=AIMAG(eigen(j))
cxx                  do k=j+1,nreigen
cxx                     eigenkr= REAL(eigen(k))
cxx                     eigenki=AIMAG(eigen(k))
cxx                     deigen(1)=MIN(deigen(1),ABS(eigenjr-eigenkr))
cxx                     deigen(2)=MIN(deigen(2),ABS(eigenji-eigenki))
cxx                  end do
cxx               end do
cxxChange: 26 Apr 95
cxxc       Ensure a non-zero minimum separation
cxx               deigen(1)=MAX(deigen(1)*.5,.000001)
cxx               deigen(2)=MAX(deigen(2)*.5,.000001)
Change: 26 Apr 95
c       Use LUB (haven't we been here before?)
               thtinc=lub*4.
               tol(1)=lub
               tol(2)=lub/5.
               dtheta(1)=tol(1)*2.
               dtheta(2)=tol(2)*2.
               deigen(1)=tol(1)/4.
               deigen(2)=tol(2)/4.

               if (print_swg .gt. 0)

     &            write(lwpcLOG_lun,
     &                '(''Iteration parameters:''/
     &                  ''    lub    thtinc    tolr    toli'',
     &                  ''    dthtar  dthtai    deignr    deigni''/
     &                  3(1x,2f8.4),1x,2f10.6)')
     &                  lub,thtinc,tol,dtheta,deigen
            end if

            if (nreigen .eq. 0) then

c              NO MODES FOUND: SKIP SEGMENT
               if (print_swg .gt. 0)
     &            write(lwpcLOG_lun,
     &                '(/''[LWP_DRIVER] WARNING: '',
     &                   ''MF_DRIVER found no modes; SKIP SEGMENT'')')
               call LWPC_ERROR ('ERROR','MF_DRIVER found no modes')
               num(nsgmnt)=-1
               nsgmnt=nrsgmnt+1
            else

               call SW_STEP (rho0,rho,azim,dip,bfield)
               if (lostm .lt. 2) then

Change: 10 Nov 93: Successful; make sure that flags are reset
                  iexact=iexact_sav
                  rpoly =irpoly_sav

c                 Store data for this segment
                  num(nsgmnt)=nreigen
                  do neigen=1,nreigen
                     save_tp  (nsgmnt,  neigen)=tp  (  neigen)
                     save_fofr(nsgmnt,  neigen)=fofr(  neigen)
                     save_capt(nsgmnt,1,neigen)=capt(1,neigen)
                     save_capt(nsgmnt,2,neigen)=capt(2,neigen)
                     save_capt(nsgmnt,3,neigen)=capt(3,neigen)
                     save_capt(nsgmnt,4,neigen)=capt(4,neigen)
                  end do

c                 Get next segment
                  call SW_NEXT (pflag,nsgmnt0,nsgmnt)
               else

                  if (lostm .eq. 3 .and. iexact .eq. 1) then

Change: 14 Nov 94: Use mode parameters as computed by MF
                     if (print_swg .gt. 0)

     &                  write(lwpcLOG_lun,
     &                      '(/''Continuing with mode parameters '',
     &                         ''from MF_DRIVER'')')

c                    Refresh the list of starting solutions
                     call MF_DRIVER

c                    Get mode parameters
                     call MF_GET_MC

c                    Reset flags
                     iexact=iexact_sav
                     rpoly =irpoly_sav

c                    Store data for this segment
                     num(nsgmnt)=nreigen
                     do neigen=1,nreigen
                        save_tp  (nsgmnt,  neigen)=tp  (  neigen)
                        save_fofr(nsgmnt,  neigen)=fofr(  neigen)
                        save_capt(nsgmnt,1,neigen)=capt(1,neigen)
                        save_capt(nsgmnt,2,neigen)=capt(2,neigen)
                        save_capt(nsgmnt,3,neigen)=capt(3,neigen)
                        save_capt(nsgmnt,4,neigen)=capt(4,neigen)
                     end do

c                    Get next segment
                     call SW_NEXT (pflag,nsgmnt0,nsgmnt)
                  else

c                    RESTART WITH MF
                     nsgmnt0=nsgmnt

Change: 10 Nov 93: Do the restart using IEXACT=1 and RPOLY=0
                     iexact=1
                     rpoly =0
                  end if
               end if
            end if
         end do

         if (nsgmnt .gt. nrsgmnt) then
            nsgmnt0=1
            do while (nsgmnt0 .le. nrsgmnt .and. num(nsgmnt0) .ne. 0)
               nsgmnt0=nsgmnt0+1
            end do
         end if
      end do

      call LWP_SAVE_MC (begin_file)

      RETURN
      END      ! LWP_DRIVER


      SUBROUTINE LW_FULL_MC
     &          (print_mc,print_wf,jflag)

c***********************************************************************

c     Compute conversion coefficients using rigorous formulation.

c***********************************************************************

c     INPUT PARAMETERS:

c     print_mc      Indicates levels of print from ModeConversion
c                   =0: minimum print
c                   =1: adds conversion coefficients
c                   =2: adds integrals

c     print_wf      Indicates levels of print from WaveFields
c                   =0: minimum print
c                   =1: adds iterations
c                   =2: adds fields vs. height

c     stp           sine(theta')
c     nreigen       number of theta'
c     nsgmnt        path segment number

c     OUTPUT PARAMETERS:

c     a             conversion coefficients

c     Note that CAPI and NORM are used differently here than in
c     LW_FAST_MC, but it's OK because the parameters are not passed
c     between this routine and LW_FAST_MC.

c  Change History:
c     21 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c     06 Sep 98     Added test to delete modes near (90,0).

c*******************!***************************************************

      IMPLICIT REAL*8 (a-h,o-z)

c     LWPC parameters
      include      'lwpc_lun.cmn'

      parameter    (mxeigen=50,nrht=65)

c     LWPC
      character*  8 archive,prgm_id
      character* 20 xmtr_id,path_id
      character* 40 prfl_id
      character* 80 case_id
      character*120 file_id
      integer       pflag,pindex
      real     *  4 freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht

      common/lwpc_in/
     &              archive,file_id(3),prgm_id,
     &              case_id,prfl_id,xmtr_id,path_id,
     &              freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht,pindex

c     Mode Conversion
      character*120 prfl_file
      integer       lu_wfd,lu_wfa,lu_wfp,mc_step,arb_azim
      real     *  8 max_wf_ht,mc_test
      complex  *  8 a,tp,stp,xtra,eyhy
      complex  * 16 norm,capi

      common/mc_inpt/
     &              prfl_file,max_wf_ht,mc_test,
     &              lu_wfd,lu_wfa,lu_wfp,mc_step,arb_azim
     &      /mc_slab/
     &              a(mxeigen,mxeigen),tp(mxeigen),stp(mxeigen),
     &              xtra(3,mxeigen),eyhy(mxeigen),nreigen,nsgmnt
     &      /mc_stor/
     &              norm(mxeigen),capi(mxeigen,mxeigen)

c     Wave Fields
      real     *  8 freq2,azim2,codip2,magfld2,sigma2,epsr2,
     &              max_ht,del_ht,top_ht,bot_ht,
     &              dtheta,lub,thtinc,alpha,h,prec
      complex  * 16 eigen2

      common/wf_inpt/
     &              eigen2,
     &              freq2,azim2,codip2,magfld2,sigma2,epsr2,
     &              max_ht,del_ht,top_ht,bot_ht
     &      /wf_iter/
     &              dtheta(2),lub(2),thtinc,alpha,h,prec,
     &              iter_flag,mxiter,nriter

c     Local
      logical       first/.true./
      integer       print_mc,print_wf,pnmode
      complex  * 16 MC_P_INTEG,
     &              eigen,sine,exc(3),
     &              eyk,ezk,hyk,hzk,eym,ezm,hym,hzm,prod

      common        eyk(nrht),ezk(nrht),hyk(nrht),hzk(nrht),
     &              eym(nrht),ezm(nrht),hym(nrht),hzm(nrht),prod(nrht)

      data          dtr/1.745329252d-2/

      if (first) then

c        Open scratch files
c        NOTE: On a VMS machine, use 1060 instead of 4240.

c        Wave fields: direct
         OPEN (lu_wfd,access='direct',status='scratch',recl=4240)

c        Wave fields: adjoint
         OPEN (lu_wfa,access='direct',status='scratch',recl=4240)

c        Wave fields: direct; from previous slab
         OPEN (lu_wfp,access='direct',status='scratch',recl=4240)

         first=.false.
      end if

c*****
c     Transfer variables from LWPC to WF commons
      freq2  =freq
      azim2  =azim
      codip2 =90.-dip
      magfld2=bfield*1.e-4
      sigma2 =sigma
      epsr2  =epsr

c     Set height intervals for WF_DRIVER to give NRHT points

c     MAX_HT defines a uniform top of the ionosphere for calculating the
c     wave fields across slab boundaries while TOP_HT and BOT_HT can
c     change from one slab to the next.
      max_ht=max_wf_ht
      del_ht=DINT(max_ht+.99)/(nrht-1)

      top_ht=DINT(top ht/del_ht+.99)*del_ht
      bot_ht=DINT(bot ht/del_ht    )*del_ht
      if (print_wf .gt. 0) then
         write(lwpcLOG_lun,
     &       '(/''LW_FULL_MC:''/
     &          ''   rho    lat     lon    azim   dip  bfield'',
     &          ''   sigma  epsr  beta   h''''''/
     &          f7.0,f7.2,f8.2,2f7.2,f7.4,1pe9.1,0pf5.1,2f6.2)')
     &          rho,lat,lon,azim,dip,bfield,sigma,epsr,beta,hprime
         write(lwpcLOG_lun,
     &       '(/''   bot   ='',f6.1,5x,'' top   ='',f6.1,5x,
     &          '' max_ht='',f6.1/
     &          ''   bot_ht='',f11.6,  '' top_ht='',f11.6,
     &          '' del_ht='',f11.6/)')
     &          bot ht,top ht,max_ht,bot_ht,top_ht,del_ht
      end if
c*****

c     Loop over WF_DRIVER to get fields vs. height

c     Temporary (?) fix for failure to converge to a solution:
c        Drop the offending mode

c     do neigen=1,nreigen
c        eigen2=tp(neigen)
c        call WF_DRIVER
c    &       (lwpcLOG_lun,lu_wfd,lu_wfa,print_wf,nsgmnt,neigen,arb_azim)
c     end do

      neigen=1
      do while (neigen .le. nreigen)
         eigen2=tp(neigen)
         call WF_DRIVER
     &       (lwpcLOG_lun,lu_wfd,lu_wfa,print_wf,nsgmnt,neigen,arb_azim)

         if ((nriter .gt. mxiter) .or.
     &       (ABS(DREAL(eigen2)-90.d0) .lt. lub(1) .and.
     &        ABS(DIMAG(eigen2)      ) .lt. lub(2)) .or.
     &       (-182.d0*freq2*DIMAG(SIN(eigen2*dtr)) .lt. .01)) then

c           Drop mode if there were too many iterations or
c                        the mode is invalid (close to 90,0)
            nreigen=nreigen-1
            do n=neigen,nreigen
               tp  (n)=tp  (n+1)
               stp (n)=stp (n+1)
               eyhy(n)=eyhy(n+1)
               do j=1,3
                  xtra(j,n)=xtra(j,n+1)
               end do
            end do
         else

c           Keep the current mode
            neigen=neigen+1
         end if
      end do

c     Calculate normalization terms
      err max=0.d0
      do m=1,nreigen

c        Get direct fields
         read (lu_wfd,rec=m) eigen,sine,exc,eym,ezm,hym,hzm

         if (iter_flag .eq. 1) then

c           Store revised eigen angles (from WF_ITRATE)
            tp(m)=eigen
            stp(m)=sine

c           Get revised ratio Ey/Hy at the ground
            eyhy(m)=eym(1)

            if (nsgmnt .eq. 1) then

c              Get revised excitation factors (from WF_RBARS)
               xtra(1,m)=exc(1)
               xtra(2,m)=exc(2)
               xtra(3,m)=exc(3)
            end if
         end if

         if (arb_azim .eq. 0) then

c           Get direct fields
            read (lu_wfd,rec=m) eigen,sine,exc,eyk,ezk,hyk,hzk
         else

c           Get adjoint fields
            read (lu_wfa,rec=m) eigen,sine,exc,eyk,ezk,hyk,hzk
         end if
         do j=1,nrht
            prod(j)=hzm(j)*eyk(j)-hym(j)*ezk(j)
     &             -ezm(j)*hyk(j)+eym(j)*hzk(j)
         end do
         norm(m)=MC_P_INTEG (del_ht,nrht,prod,err)
         if (err max .lt. err) err max=err

         if (print_mc .gt. 1)
     &      write(lwpcLOG_lun,
     &          '(''LW_FULL_MC: '',
     &            ''NORM('',i2,'')='',1p2e15.5,1x,
     &            ''err='',1pe12.2)')
     &              m,norm(m),err
      end do

      if (print_mc .gt. 1)
     &   write(lwpcLOG_lun,
     &       '(''LW_FULL_MC: '',
     &         ''NORM: Max. error ='',1pe10.2)')
     &           err max

      if (nsgmnt .eq. 1) then

         do k=1,nreigen
            do m=1,nreigen
               if (k .eq. m) then
                  a(k,m)=(1.d0,0.d0)
               else
                  a(k,m)=(0.d0,0.d0)
               end if
            end do
         end do
      else

         if (jflag .eq. 1) then

            err max=0.d0
            do k=1,pnmode

c              Get direct fields from previous slab
               read (lu_wfp,rec=k) eigen,sine,exc,eyk,ezk,hyk,hzk

               do m=1,nreigen
                  if (arb_azim .eq. 0) then

c                    Get direct fields
                     read (lu_wfd,rec=m) eigen,sine,exc,eym,ezm,hym,hzm
                  else

c                    Get adjoint fields
                     read (lu_wfa,rec=m) eigen,sine,exc,eym,ezm,hym,hzm
                  end if
                  do j=1,nrht
                     prod(j)=hzm(j)*eyk(j)-hym(j)*ezk(j)
     &                      -ezm(j)*hyk(j)+eym(j)*hzk(j)
                  end do
                  capi(m,k)=MC_P_INTEG (del_ht,nrht,prod,err)
                  if (err max .lt. err) err max=err

                  if (print_mc .gt. 1)
     &               write(lwpcLOG_lun,
     &                   '(''LW_FULL_MC: '',
     &                     ''CAPI('',i2,'','',i2,'')='',1p2e15.5,1x,
     &                     ''err='',1pe12.2)')
     &                       k,m,capi(m,k),err
               end do
            end do
            if (print_mc .gt. 1)
     &         write(lwpcLOG_lun,
     &             '(''LW_FULL_MC: '',
     &               ''CAPI: Max. error ='',1pe10.2)')
     &                 err max

c           Compute total conversion
            do k=1,pnmode
               do m=1,nreigen
                  a(k,m)=capi(m,k)/norm(m)
               end do
            end do
         end if
      end if

      pnmode=nreigen
      do k=1,nreigen
         read (lu_wfd,rec=k) eigen,sine,exc,eyk,ezk,hyk,hzk
         write(lu_wfp,rec=k) eigen,sine,exc,eyk,ezk,hyk,hzk
      end do

      RETURN
      END      ! LW_FULL_MC


!
!***********************************************************************
!                                                                      *
      module Coupling_constants
!                                                                      *
!     Written by G. Gaigalas,                                          *
!                                                                      *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
!-----------------------------------------------
!   G l o b a l   V a r i a b l e s
!-----------------------------------------------
      integer, parameter, public :: i4b = selected_int_kind(9)
      integer, parameter, public :: i2b = selected_int_kind(4)
      integer, parameter, public :: i1b = selected_int_kind(2)
      integer, parameter, public :: sp  = kind(1.0)
      integer, parameter, public :: dp  =                              &
                                 selected_real_kind(2*precision(1.0_sp))
      real(kind=dp), parameter, public :: ZERO_dp = 0.0
      real(kind=dp), parameter, public :: ONE_dp = 1.0
      real(kind=dp), parameter, public :: TWO_dp = 2.0
      real(kind=dp), public ::    dp_coeff_precision     = 0.00000001
      real(kind=dp), public ::    dp_coeff_precision_t10 = 0.000001
      real(kind=sp), public ::    sp_coeff_precision     = 0.0000001
!     read unit
      integer, parameter, public :: iread_csf   = 1        !for csf (usually file "csf.inp")
      integer, parameter, public :: iread_coefs = 2        !for J-matrices and coefficients (usially file "name.j")
      integer, parameter, public :: iwrite_log  = 3
      integer, parameter, public :: iwrite_log2 = 3
      integer, parameter, public :: iwrite_expansions           = 16
      integer, parameter, public :: iwrite_cfg_expansions_JJ    =  7
      integer, parameter, public :: iwrite_cfg_expansions_LK    =  8
      integer, parameter, public :: iwrite_cfg_expansions_JK    =  9
      integer, parameter, public :: iwrite_cfg_expansions_LS3   = 12
      integer, parameter, public :: iwrite_cfg_expansions_LSJ3  = 13
      integer, parameter, public :: iwrite_cfg_expansions_LK3   = 14
      integer, parameter, public :: iwrite_cfg_expansions_JK3   = 15
      integer, parameter, public :: iwrite_cfg_expansions_cLSJ3 = 17
      integer, parameter, public :: iwrite_cfg_expansions_LScjj = 18
      integer, parameter, public :: iwrite_cfg_expansions_jj123 = 19
      integer, parameter, public :: iwrite_classifications      = 10
      integer, parameter, public :: iwrite_DataBase_LS          = 50
      integer, parameter, public :: iwrite_DataBase_JJ          = 51
      integer, parameter, public :: iwrite_DataBase_LK          = 52
      integer, parameter, public :: iwrite_DataBase_JK          = 53
      integer, parameter, public :: iwrite_DataBase_LS3         = 64
      integer, parameter, public :: iwrite_DataBase_LSJ3        = 65
      integer, parameter, public :: iwrite_DataBase_LK3         = 56
      integer, parameter, public :: iwrite_DataBase_JK3         = 57
      integer, parameter, public :: iwrite_DataBase_cLSJ3       = 58
      integer, parameter, public :: iwrite_DataBase_LScjj       = 59
      integer, parameter, public :: iwrite_DataBase_jj123       = 60
      integer, parameter, public ::                              &
                          iwrite_classifications_evaluations =  11
      integer, parameter, public :: iwrite_suggestions       =  70
!
      integer, parameter, public :: NOTATION =1  ! for ASD clasification
!      integer, parameter, public :: NOTATION =0  ! for ATSP2K and GRASP2K
!-----------------------------------------------
      end module Coupling_constants


!====================================================================
!>
!! CRTM AMSU-B module for STMAS assimilation
!!
!! \history \n
!! Creation: Yuanfu Xie 2013
!
!====================================================================
MODULE crtm_kmatrix

  USE CRTM_MODULE
  USE prmtrs_stmas_cloud, only : satellite_obs

  IMPLICIT NONE

  CHARACTER(*), PARAMETER :: program_name = 'lvd_da'

  ! Parameters which could be ported to sat_da.nl later.
  INTEGER, PARAMETER :: num_lvd_sensor = 1
  INTEGER, PARAMETER :: num_lvd_absorber = 2
  INTEGER, PARAMETER :: num_lvd_cloud = 0
  INTEGER, PARAMETER :: num_lvd_aerosol = 0
  REAL(FP),    PARAMETER :: lvd_zenith_angle=-34.04_fp, lvd_scan_angle=-30.20_fp

  INTEGER :: num_lvd_channels

  type(CRTM_ChannelInfo_Type), allocatable:: lvd_ChannelInfo(:)
  type(CRTM_Geometry_Type),    allocatable:: lvd_GeometryInfo(:)
  type(CRTM_Atmosphere_Type),  allocatable:: lvd_Atm(:)     ! Profiles
  type(CRTM_Atmosphere_Type),  allocatable:: lvd_Atm_K(:,:) ! Channel x profiles
  type(CRTM_Surface_Type),     allocatable:: lvd_Sfc(:)     ! Profiles
  type(CRTM_Surface_Type),     allocatable:: lvd_Sfc_K(:,:) ! Channel x profile
  ! RTSolution and RTSolution_K: Channels x profiles
  type(CRTM_RTSolution_Type),  allocatable:: lvd_RTSolution(:,:), &
                                             lvd_RTSolution_K(:,:)
CONTAINS

!====================================================================
!>
!! CRTM configuration for GOES.
!!
!! \history \n
!! Creation: Yuanfu Xie 2013, S Albers (modified for GOES)
!
!====================================================================

SUBROUTINE conf4lvd(lvd,numgrid,sensor_id,coe_path,moist_unit,&
                      badflag)

  IMPLICIT NONE

  CHARACTER(*), INTENT(IN) :: sensor_id,coe_path,moist_unit
  INTEGER, INTENT(IN) :: numgrid(4)
  REAL,    INTENT(IN) :: badflag
  TYPE(SATELLITE_OBS), INTENT(IN) :: lvd
  REAL(fp) :: angle(4,lvd%numpro)

  ! Local variables:
  CHARACTER(256) :: message
  INTEGER :: istatus,np

  ! Allocate memory for AMSU-B assimilation:
  ALLOCATE(lvd_ChannelInfo(num_lvd_sensor), &
           lvd_GeometryInfo(lvd%numpro), &
           STAT=istatus)

  istatus = CRTM_Init( (/sensor_id/), lvd_ChannelInfo, &
                        EmisCoeff_File='Wu-Smith.EmisCoeff.bin', &
                        File_Path=TRIM(coe_path)//'Coefficient_Data/', &
                        Quiet = .TRUE.)
  IF ( istatus /= SUCCESS ) THEN
    message = 'Error initializing CRTM'
    CALL Display_Message( PROGRAM_NAME, message, FAILURE )
    STOP
  ELSE
    message = 'CRTM initialized'
    call Display_Message( program_name, message, SUCCESS )
  ENDIF
  num_lvd_channels = SUM(lvd_ChannelInfo%n_channels)
  IF (num_lvd_channels .NE. lvd%numchs) THEN
    PRINT*,'Numbers of AMSUB channels do not match!'
    STOP
  ENDIF

  ! Allocate memory for CRTM arrays:
  ALLOCATE(lvd_RTSolution(lvd%numchs,lvd%numpro), &
           lvd_RTsolution_K(lvd%numchs,lvd%numpro), &
           lvd_Atm(lvd%numpro), &
           lvd_Sfc(lvd%numpro), &
           lvd_Atm_K(lvd%numchs,lvd%numpro), &
           lvd_Sfc_K(lvd%numchs,lvd%numpro), &
           STAT=istatus)

  ! Create CRTM:
  CALL CRTM_Atmosphere_Create(lvd_Atm,numgrid(3),num_lvd_absorber, &
                              num_lvd_cloud,num_lvd_aerosol)
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(lvd_Atm)) ) THEN
     message = 'Error allocating CRTM Atmosphere structures'
     CALL Display_Message( PROGRAM_NAME, message, FAILURE )
     STOP
  ENDIF
  CALL CRTM_Atmosphere_Create(lvd_Atm_K,numgrid(3),num_lvd_absorber, &
                              num_lvd_cloud,num_lvd_aerosol)
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(lvd_Atm)) ) THEN
     message = 'Error allocating CRTM Atmosphere_K structures'
     CALL Display_Message( PROGRAM_NAME, message, FAILURE )
     STOP
  ENDIF

  ! Data type conversion: real to real(fp) of CRTM:
  angle = lvd%angles

  ! Geometry setting:
  CALL CRTM_Geometry_SetValue( lvd_GeometryInfo, &
                               iFOV = lvd%numpro, &
                               Sensor_Zenith_Angle  = angle(1,1:lvd%numpro), &
                               Sensor_Azimuth_Angle = angle(2,1:lvd%numpro), &
                               Source_Zenith_Angle  = angle(3,1:lvd%numpro), &
                               Source_Azimuth_Angle = angle(4,1:lvd%numpro) )

  ! Pass the non-control profile values to CRTM:
  DO np=1,lvd%numpro

    IF (lvd%lndcvr(np) .GT. 0) THEN
      lvd_Sfc(np)%Land_Coverage  = 1.0_fp
      lvd_Sfc(np)%Water_Coverage  = 0.0_fp
    ELSE
      lvd_Sfc(np)%Land_Coverage  = 0.0_fp
      lvd_Sfc(np)%Water_Coverage  = 1.0_fp
    ENDIF
    lvd_Sfc(np)%Land_type      = 1 ! COMPACTED SOIL, ACCORDING CRTM 2.1.1
    lvd_Sfc(np)%Water_type     = 1 ! SEA_WATER
    lvd_Atm(np)%Absorber_Id    = (/ H2O_ID , O3_ID /)
    lvd_Atm(np)%Absorber(:,2)  = 2.53e-3  ! Fake value as MHS does not use O3

    ! Currently, use mass mixing ratio only CRTM user guide 2.1.1 section 4.6:
    IF (moist_unit .EQ. 'MASS_MIXING_RATIO_UNITS') THEN
      lvd_Atm(np)%Absorber_Units = (/ MASS_MIXING_RATIO_UNITS,  &
                                        VOLUME_MIXING_RATIO_UNITS /)
    ELSE
      PRINT*,'Not implemented, check the namelist, sat_da.nl'
      STOP
    ENDIF

  ENDDO

END SUBROUTINE conf4lvd

!====================================================================
!>
!! CRTM forward and K-matrix calculation for AMSU-B.
!!
!! \history \n
!! Creation: Yuanfu Xie 2013
!
!====================================================================

SUBROUTINE lvd_costgrad(numgrid,u_sfc,v_sfc,pres,sh,temp,lvd,tf, &
                          badflag,cost,grad,lvd_channels_used, &
                          iu,iv,it,iq)

  IMPLICIT NONE

  TYPE(satellite_obs), INTENT(IN) :: lvd

  INTEGER, INTENT(IN) :: numgrid(4),lvd_channels_used(*)
  INTEGER, INTENT(IN) :: tf,iu,iv,it,iq  ! Time frame and indices for control variables
  REAL,    INTENT(IN) :: pres(numgrid(3))
  REAL,    INTENT(IN) ::   sh(lvd%numpro,numgrid(3))
  REAL,    INTENT(IN) :: temp(lvd%numpro,numgrid(3))
  REAL,    INTENT(IN) :: u_sfc(lvd%numpro)
  REAL,    INTENT(IN) :: v_sfc(lvd%numpro)
  REAL,    INTENT(IN) :: badflag
  REAL,   INTENT(OUT) :: cost,grad(numgrid(1),numgrid(2),numgrid(3),numgrid(4),*)

  ! Local variables:
  REAL, PARAMETER :: pi=3.1415926
  CHARACTER(256) :: message
  DOUBLE PRECISION :: f
  INTEGER :: np,nl,nc,istatus
  REAL    :: bt,spd,weight

  PRINT*,'AMSUB cost function and gradient calculation...'

  DO np=1,lvd%numpro

    ! 2D fields:
    lvd_Sfc(np)%Land_Temperature = temp(np,1)
    lvd_Sfc(np)%Wind_Speed = SQRT(u_sfc(np)**2+v_sfc(np)**2)
    lvd_Sfc(np)%Wind_Direction = (2.0*pi+ASIN(v_sfc(np)/lvd_Sfc(np)%Wind_Speed))*180.0/pi

    ! 3D fields:
    ! Note: future improvement would be using terrain-following coordinate:
    ! Currently, we do not treat terrain!!!
    lvd_Atm(np)%Level_Pressure(0) = 1.5*pres(numgrid(3))-0.5*pres(numgrid(3)-1)
    DO nl=1,numgrid(3)-1
      lvd_Atm(np)%Level_Pressure(nl) = 0.5*(pres(numgrid(3)-nl)+pres(numgrid(3)-nl+1))
      lvd_Atm(np)%Pressure(nl)       = pres(numgrid(3)-nl+1)
    ENDDO
    lvd_Atm(np)%Level_Pressure(numgrid(3)) = 1.5*pres(1)-0.5*pres(2)
    lvd_Atm(np)%Pressure(numgrid(3)) = pres(1)

    ! Assign meteorological profiles to CRTM structured data:

    ! Convert specific humidity to mass mixing ratio:
    ! From the book of "Fundamentals of Atmospheric Modeling by Mark Z. Jacobson,
    ! mass mixing ratio (mmr) = rho_v/rho_d (equation 2.26) and
    ! specific humidity (sh)  = rho_v/(rho_d+rho_v) (equation 2.27). Thus
    ! mmr = sh/(1-sh).
    DO nl=1,numgrid(3)
      ! CRTM mass mixing ratio is in g/kg: Table 4.7 CRTM user guide 2.1.1:
      lvd_Atm(np)%Absorber(nl,1) = 1.0e3*sh(np,numgrid(3)-nl+1)/(1.0e3-sh(np,numgrid(3)-nl+1))
      IF (lvd_Atm(np)%Absorber(nl,1) .lt. 0.0) then
        PRINT*,'Negative Vapor? ',lvd_Atm(np)%Absorber(nl,1),nl,np
        lvd_Atm(np)%Absorber(nl,1) = 0.0
      ENDIF

      lvd_Atm(np)%Temperature(nl) = temp(np,numgrid(3)-nl+1)
    ENDDO

  ENDDO

  ! Clean up arrays for K-matrix:
  CALL CRTM_Atmosphere_Zero( lvd_Atm_k )
  CALL CRTM_Surface_Zero( lvd_Sfc_K )
  lvd_RTSolution_K%brightness_Temperature = ONE
  lvd_RTSolution_K%Radiance = ZERO

  print*,'Calling k_matrix...'

  ! K-Matrix:
  istatus = CRTM_K_Matrix( lvd_Atm         , &
                           lvd_Sfc         , &
                           lvd_RTSolution_K, &
                           lvd_GeometryInfo, &
                           lvd_ChannelInfo , &
                           lvd_Atm_K       , &
                           lvd_Sfc_K       , &
                           lvd_RTSolution  )
  IF ( istatus /= SUCCESS ) THEN
    Message = 'Error in CRTM K_Matrix Model'
    CALL Display_Message( program_name, message, FAILURE )
    STOP
  ENDIF

  ! Cost and grad:
  f = 0.0D0
  ! Break function and gradient for calculating weight:
  weight = 0.0
  DO np=1,lvd%numpro

    DO nc=1,lvd%numchs
      IF (lvd_channels_used(nc) .NE. 1) CYCLE

      bt = lvd_RTSolution(nc,np)%Brightness_Temperature

      ! Cost:
      f = f+(bt-lvd%satval(nc,np))**2
      weight = weight+0.5
    ENDDO

  ENDDO
  ! Pass the double precision cost function value to the output variable:
  ! weight = SQRT(weight)

  cost = 1.0*f/weight

  DO np=1,lvd%numpro

    DO nc=1,lvd%numchs
      IF (lvd_channels_used(nc) .NE. 1) CYCLE

      bt = lvd_RTSolution(nc,np)%Brightness_Temperature

      ! Grad:
      ! Surface:
      spd = SQRT(u_sfc(np)**2+v_sfc(np)**2)
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,it) = &
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,it)+(bt-lvd%satval(nc,np))/weight* &
        lvd_Sfc_K(nc,np)%Land_Temperature
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,iu) = &
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,iu)+(bt-lvd%satval(nc,np))/weight* &
        (lvd_Sfc_K(nc,np)%Wind_Speed*     u_sfc(np)/spd - &
         lvd_Sfc_K(nc,np)%Wind_Direction*SIGN(1.0,u_sfc(np))*v_sfc(np)/(spd*spd))*180.0/pi
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,iu) = &
      grad(lvd%grdidx(1,np),lvd%grdidx(2,np),1,tf,iv)+(bt-lvd%satval(nc,np))/weight* &
        (lvd_Sfc_K(nc,np)%Wind_Speed*     v_sfc(np)/spd + &
         lvd_Sfc_K(nc,np)%Wind_Direction*ABS(u_sfc(np))/(spd*spd))*180.0/pi

      ! 3D profiles:
      DO nl=1,numgrid(3)
        grad(lvd%grdidx(1,np),lvd%grdidx(2,np),numgrid(3)-nl+1,tf,it) = &
        grad(lvd%grdidx(1,np),lvd%grdidx(2,np),numgrid(3)-nl+1,tf,it) + &
          (bt-lvd%satval(nc,np))/weight*lvd_Atm_K(nc,np)%Temperature(nl)
        grad(lvd%grdidx(1,np),lvd%grdidx(2,np),numgrid(3)-nl+1,tf,iq) = &
        grad(lvd%grdidx(1,np),lvd%grdidx(2,np),numgrid(3)-nl+1,tf,iq) + &
          (bt-lvd%satval(nc,np))/weight*lvd_Atm_K(nc,np)%Absorber(nl,1)* &
          1.0e6/(1.0e3-sh(np,numgrid(3)-nl+1))**2
      ENDDO
    ENDDO

  ENDDO

END SUBROUTINE lvd_costgrad

!====================================================================
!>
!! Destroy the CRTM for AMSU-B.
!!
!! \history \n
!! Creation: Yuanfu Xie 2013
!
!====================================================================

SUBROUTINE dstrylvd

  ! Local variables:
  INTEGER :: istatus

  istatus = CRTM_Destroy(lvd_ChannelInfo)

END SUBROUTINE dstrylvd

END MODULE crtm_kmatrix


module neutraldata2Dobj

use, intrinsic :: ieee_arithmetic, only: ieee_is_finite
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit
use phys_consts, only: wp,debug,pi,Re
use inputdataobj, only: inputdata
use neutraldataobj, only: neutraldata
use meshobj, only: curvmesh
use config, only: gemini_cfg
use reader, only: get_grid2,get_neutral2
use timeutils, only: dateinc,date_filename
use h5fortran, only: hdf5_file
use filesystem, only: get_filename
use grid, only: gridflag

implicit none (type,external)
public :: neutraldata2D

!> type definition for 3D neutral data
type, extends(neutraldata), abstract :: neutraldata2D
  ! source data coordinate pointers
  real(wp), dimension(:), pointer :: horzn,zn
  integer, pointer :: lhorzn,lxn,lzn        ! lxn not used but still bound

  ! work arrays needed by various procedures re: target coordinates
  real(wp), dimension(:,:,:), allocatable :: horzimat,zimat
  real(wp), dimension(:), pointer :: zi,horzi

  ! source data pointers, note we only have *horizontal* wind components here
  real(wp), dimension(:,:,:), pointer :: dnO,dnN2,dnO2,dvnz,dvnhorz,dTn

  ! projection factors needed to rotate input data onto grid
  real(wp), dimension(:,:,:), allocatable :: proj_ezp_e1,proj_ezp_e2,proj_ezp_e3
  real(wp), dimension(:,:,:), allocatable :: proj_ehorzp_e1,proj_ehorzp_e2,proj_ehorzp_e3
  contains
    ! replacement for gridsize and gridload
    procedure(loadneu2D), deferred :: load_sizeandgrid_neu2D
    procedure :: rotate_winds
    procedure :: init_neu2D_simple

    ! overriding procedures
    procedure :: update
    procedure :: init_storage

    ! bindings for deferred procedures
    procedure :: load_data=>load_data_neu2D
    procedure :: load_grid=>load_grid_neu2D    ! stub, does nothing see load_sizeandgrid_neu3D()
    procedure :: load_size=>load_size_neu2D    ! stub, does nothing "

    ! defer to type extensions
    !procedure :: set_coordsi=>set_coordsi_neu2D

    ! clean up some of the pointers
    procedure :: dissociate_neutral2D_pointers
end type neutraldata2D

interface
  subroutine loadneu2D(self,cfg)
    import neutraldata2D,gemini_cfg
    class(neutraldata2D), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg
  end subroutine loadneu2D
end interface

contains
  !> initialize storage for this type of neutral input data
  subroutine init_neu2D_simple(self,cfg,sourcedir,x,dtmodel,dtdata,ymd,UTsec)
    class(neutraldata2D), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg
    character(*), intent(in) :: sourcedir
    class(curvmesh), intent(in) :: x
    real(wp), intent(in) :: dtmodel,dtdata
    integer, dimension(3), intent(in) :: ymd            ! target date of initiation
    real(wp), intent(in) :: UTsec                       ! target time of initiation
    integer :: lc1,lc2,lc3
    character(:), allocatable :: strname    ! allow auto-allocate for strings

    ! force 3D interpolation regardless of working subarray size
    !self%flagforcenative=.true.

    ! tell our object where its data are and give the dataset a name
    call self%set_source(sourcedir)
    strname='neutral perturbations (2D)'
    call self%set_name(strname)
    call self%set_cadence(dtdata)
    self%flagdoinput=cfg%flagdneu/=0

    ! set sizes, we have 7 arrays all 3D (irrespective of 2D vs. 3D neutral input).  for 3D neutral input
    !    the situation is more complicated that for other datasets because you cannot compute the number of
    !    source grid points for each worker until you have root compute the entire grid and slice everything up
    allocate(self%lc1,self%lc2,self%lc3)                                     ! these are pointers, even though scalar
    !! this is a bit tricky because the inpudata class wants non-singleton dimension to be the same; here lc1,lc2
    self%lzn=>self%lc1; self%lhorzn=>self%lc2;
    self%lxn=>self%lc3                             ! these referenced while reading size and grid data
    call self%set_coordsi(cfg,x)                   ! since this preceeds init_storage it must do the work of allocating some spaces
    call self%load_sizeandgrid_neu2D(cfg)          ! cfg needed to form source neutral grid
    call self%set_sizes( &
             0, &          ! number scalar parts to dataset
             0, 0, 0, &    ! number 1D data along each axis
             0, 0, 0, &    ! number 2D data along pairs of axes
             6, &          ! number 3D datasets, for neutraldata2D we have singleton dimensions for 2D input
             x)            ! The main purpose of this is to set the number of 3D datasets (other params already set)

    ! allocate space for arrays, note for neutrals some of this has already happened so there is an overloaded procedure
    call self%init_storage()

    ! set aliases to point to correct source data arrays
    self%dnO=>self%data3D(:,:,:,1)
    self%dnN2=>self%data3D(:,:,:,2)
    self%dnO2=>self%data3D(:,:,:,3)
    self%dvnz=>self%data3D(:,:,:,4)
    self%dvnhorz=>self%data3D(:,:,:,5)
    self%dTn=>self%data3D(:,:,:,6)    ! note this gets interpolated into a variable bound to vn3i, so need to adjust during rotations

    ! call to base class procedure to set pointers for prev,now,next (must already have space allocated)
    call self%setptrs_grid()

    ! initialize previous data so we get a correct starting value
    self%dnOiprev=0
    self%dnN2iprev=0
    self%dnO2iprev=0
    self%dvn1iprev=0
    self%dvn2iprev=0
    self%dvn3iprev=0
    self%dTniprev=0

    ! set to start time of simulation - not needed since assigned by update on first call.  FIXME: a bit messy
    !self%ymdref(:,1)=cfg%ymd0; self%ymdref(:,2)=cfg%ymd0;
    !self%UTsecref(1)=cfg%UTsec0; self%UTsecref(2)=cfg%UTsec0;

    ! prime input data
    call self%prime_data(cfg,x,dtmodel,ymd,UTsec)
  end subroutine init_neu2D_simple

  !> create storage for arrays needed specifically for 3D neutral input calculations, overrides the base class procedure
  subroutine init_storage(self)
    class(neutraldata2D), intent(inout) :: self
    integer :: lc1,lc2,lc3
    integer :: lc1i,lc2i,lc3i
    integer :: l0D
    integer :: l1Dax1,l1Dax2,l1Dax3
    integer :: l2Dax23,l2Dax12,l2Dax13
    integer :: l3D

    ! check sizes are set
    if (.not. self%flagsizes) error stop 'inpudata:init_storage(); must set sizes before allocations...'

    ! local size variables for convenience
    lc1=self%lc1; lc2=self%lc2; lc3=self%lc3;
    lc1i=self%lc1i; lc2i=self%lc2i; lc3i=self%lc3i;
    l0D=self%l0D
    l1Dax1=self%l1Dax1; l1Dax2=self%l1Dax2; l1Dax3=self%l1Dax3;
    l2Dax23=self%l2Dax23; l2Dax12=self%l2Dax12; l2Dax13=self%l2Dax13;
    l3D=self%l3D

    ! NOTE: type extensions are reponsible for zeroing out any arrays they will use in their own init() bindings

    ! input data coordinate arrays are set by load_gridandsize()

    ! allocate target coords, for neutral3D the standard set (coord1i, etc.) are done in set_coordsi()
    allocate(self%coord1iax1(lc1i),self%coord2iax2(lc2i),self%coord3iax3(lc3i))
    allocate(self%coord2iax23(lc2i*lc3i),self%coord3iax23(lc2i*lc3i))
    allocate(self%coord1iax13(lc1i*lc3i),self%coord3iax13(lc1i*lc3i))
    allocate(self%coord1iax12(lc1i*lc2i),self%coord2iax12(lc1i*lc2i))

    ! allocate object arrays for input data at a reference time.  FIXME: do we even need to store this perm. or can be local to
    ! load_data?
    allocate(self%data0D(l0D))
    allocate(self%data1Dax1(lc1,l1Dax1), self%data1Dax2(lc2,l1Dax2), self%data1Dax3(lc3,l1Dax3))
    allocate(self%data2Dax23(lc2,lc3,l2Dax23), self%data2Dax12(lc1,lc2,l2Dax12), self%data2Dax13(lc1,lc3,l2Dax13))
    allocate(self%data3D(lc1,lc2,lc3,l3D))

    ! allocate object arrays for interpolation sites at reference times
    allocate(self%data0Di(l0D,2))
    allocate(self%data1Dax1i(lc1i,l1Dax1,2), self%data1Dax2i(lc2i,l1Dax2,2), self%data1Dax3i(lc3i,l1Dax3,2))
    allocate(self%data2Dax23i(lc2i,lc3i,l2Dax23,2), self%data2Dax12i(lc1i,lc2i,l2Dax12,2), self%data2Dax13i(lc1i,lc3i,l2Dax13,2))
    allocate(self%data3Di(lc1i,lc2i,lc3i,l3D+1,2))     ! note extra parameter for three vector components!!!

    ! allocate object arrays at interpolation sites for current time.  FIXME: do we even need to store permanently?
    allocate(self%data0Dinow(l0D))
    allocate(self%data1Dax1inow(lc1i,l1Dax1), self%data1Dax2inow(lc2i,l1Dax2), self%data1Dax3inow(lc3i,l1Dax3))
    allocate(self%data2Dax23inow(lc2i,lc3i,l2Dax23), self%data2Dax12inow(lc1i,lc2i,l2Dax12), self%data2Dax13inow(lc1i,lc3i,l2Dax13))
    allocate(self%data3Dinow(lc1i,lc2i,lc3i,l3D+1))    ! +1 because even with 2D input we still need to track 3 comps.

    self%flagalloc=.true.
  end subroutine init_storage

  !> do nothing stub
  subroutine load_size_neu2D(self)
    class(neutraldata2D), intent(inout) :: self

  end subroutine load_size_neu2D

  !> do nothing stub
  subroutine load_grid_neu2D(self)
    class(neutraldata2D), intent(inout) :: self

  end subroutine load_grid_neu2D

  !> Have all workers separately load data out of file to avoid message passing
  subroutine load_data_neu2D(self,t,dtmodel,ymdtmp,UTsectmp)
    class(neutraldata2D), intent(inout) :: self
    real(wp), intent(in) :: t,dtmodel
    integer, dimension(3), intent(inout) :: ymdtmp
    real(wp), intent(inout) :: UTsectmp
    integer :: iid,ierr
    integer :: lhorzn,lzn                        !number of horizontal grid points
    real(wp), dimension(:,:,:), allocatable :: paramall
    type(hdf5_file) :: hf
    character(:), allocatable :: fn

    ! sizes for convenience
    lhorzn=self%lhorzn; lzn=self%lzn;

    ymdtmp = self%ymdref(:,2)
    UTsectmp = self%UTsecref(2)
    call dateinc(self%dt,ymdtmp,UTsectmp)                !get the date for "next" params

    call get_neutral2(date_filename(self%sourcedir,ymdtmp,UTsectmp), &
      self%dnO,self%dnN2,self%dnO2,self%dvnhorz,self%dvnz,self%dTn)

    if (debug) then
      print *, 'Min/max values for dnO:  ',minval(self%dnO),maxval(self%dnO)
      print *, 'Min/max values for dnN:  ',minval(self%dnN2),maxval(self%dnN2)
      print *, 'Min/max values for dnO:  ',minval(self%dnO2),maxval(self%dnO2)
      print *, 'Min/max values for dvnhorz:  ',minval(self%dvnhorz),maxval(self%dvnhorz)
      print *, 'Min/max values for dvnz:  ',minval(self%dvnz),maxval(self%dvnz)
      print *, 'Min/max values for dTn:  ',minval(self%dTn),maxval(self%dTn)
    endif

    if (.not. all(ieee_is_finite(self%dnO))) error stop 'dnO: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%dnN2))) error stop 'dnN2: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%dnO2))) error stop 'dnO2: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%dvnhorz))) error stop 'dvnhorz: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%dvnz))) error stop 'dvnz: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%dTn))) error stop 'dTn: non-finite value(s)'

    ! print some diagnostics for the input data
    if (debug) then
      print*, 'neutral data size:  ',lhorzn,lzn
      print *, 'Min/max values for dnO:  ',minval(self%dnO),maxval(self%dnO)
      print *, 'Min/max values for dnN:  ',minval(self%dnN2),maxval(self%dnN2)
      print *, 'Min/max values for dnO:  ',minval(self%dnO2),maxval(self%dnO2)
      print *, 'Min/max values for dvnrho:  ',minval(self%dvnhorz),maxval(self%dvnhorz)
      print *, 'Min/max values for dvnz:  ',minval(self%dvnz),maxval(self%dvnz)
      print *, 'Min/max values for dTn:  ',minval(self%dTn),maxval(self%dTn)
      !print*, 'coordinate ranges:  ',minval(zn),maxval(zn),minval(rhon),maxval(rhon),minval(zi),maxval(zi),minval(rhoi),maxval(rhoi)
    end if
  end subroutine load_data_neu2D

  !> overriding procedure for updating neutral atmos (need additional rotation steps)
  subroutine update(self,cfg,dtmodel,t,x,ymd,UTsec)
    class(neutraldata2D), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg
    real(wp), intent(in) :: dtmodel             ! need both model and input data time stepping
    real(wp), intent(in) :: t                   ! simulation absoluate time for which perturabation is to be computed
    class(curvmesh), intent(in) :: x            ! mesh object
    integer, dimension(3), intent(in) :: ymd    ! date for which we wish to calculate perturbations
    real(wp), intent(in) :: UTsec               ! UT seconds for which we with to compute perturbations

    ! execute a basic update
    call self%update_simple(cfg,dtmodel,t,x,ymd,UTsec)

    ! FIXME: more efficient to rotate only when a read/interpolate in space is done?
    ! now we need to rotate velocity fields following interpolation (they are magnetic ENU prior to this step)
    call self%rotate_winds()

    ! print some diagnostic data once the udpate has occurred
    if (debug) then
      print*, ''
      print*, 'neutral data size:  ',self%lzn,self%lhorzn,self%lxn
      print*, 'neutral data time:  ',ymd,UTsec
      print*, ''
      print *, 'Min/max values for dnOinext:  ',minval(self%dnOinext),maxval(self%dnOinext)
      print *, 'Min/max values for dnN2inext:  ',minval(self%dnN2inext),maxval(self%dnN2inext)
      print *, 'Min/max values for dnO2inext:  ',minval(self%dnO2inext),maxval(self%dnO2inext)
      print *, 'Min/max values for dvn1inext:  ',minval(self%dvn1inext),maxval(self%dvn1inext)
      print *, 'Min/max values for dvn2inext:  ',minval(self%dvn2inext),maxval(self%dvn2inext)
      print *, 'Min/max values for dvn3inext:  ',minval(self%dvn3inext),maxval(self%dvn3inext)
      print *, 'Min/max values for dTninext:  ',minval(self%dTninext),maxval(self%dTninext)
      print*, ''
      print *, 'Min/max values for dnOinow:  ',minval(self%dnOinow),maxval(self%dnOinow)
      print *, 'Min/max values for dnN2inow:  ',minval(self%dnN2inow),maxval(self%dnN2inow)
      print *, 'Min/max values for dnO2inow:  ',minval(self%dnO2inow),maxval(self%dnO2inow)
      print *, 'Min/max values for dvn1inow:  ',minval(self%dvn1inow),maxval(self%dvn1inow)
      print *, 'Min/max values for dvn2inow:  ',minval(self%dvn2inow),maxval(self%dvn2inow)
      print *, 'Min/max values for dvn3inow:  ',minval(self%dvn3inow),maxval(self%dvn3inow)
      print *, 'Min/max values for dTninow:  ',minval(self%dTninow),maxval(self%dTninow)
    end if
  end subroutine update

  !> This subroutine takes winds stored in self%dvn?inow and applies a rotational transformation onto the
  !      grid object for this simulation.  Provided that the horizontal projections have been computed
  !      correctly the same rotation can be used for axisymmetric and cartesian.
  subroutine rotate_winds(self)
    class(neutraldata2D), intent(inout) :: self
    integer :: ix1,ix2,ix3
    real(wp) :: vnhorz,vnz,Tn

    ! do rotations one grid point at a time to cut down on temp storage needed.  Note that until this point there
    !   shoudl be only zero data stored in vn3 since this class is for 2D data input, instead temperature
    !   gets stored in the dvn3i variables.
    do ix3=1,self%lc3i
      do ix2=1,self%lc2i
        do ix1=1,self%lc1i
          vnz=self%dvn1inow(ix1,ix2,ix3)
          vnhorz=self%dvn2inow(ix1,ix2,ix3)
          Tn=self%dvn3inow(ix1,ix2,ix3)    ! need to save because it will get overwritten in rotation
          self%dvn1inow(ix1,ix2,ix3)=vnz*self%proj_ezp_e1(ix1,ix2,ix3) + &
                                        vnhorz*self%proj_ehorzp_e1(ix1,ix2,ix3)
          self%dvn2inow(ix1,ix2,ix3)=vnz*self%proj_ezp_e2(ix1,ix2,ix3) + &
                                        vnhorz*self%proj_ehorzp_e2(ix1,ix2,ix3)
          self%dvn3inow(ix1,ix2,ix3)=vnz*self%proj_ezp_e3(ix1,ix2,ix3) + &
                                        vnhorz*self%proj_ehorzp_e3(ix1,ix2,ix3)
          self%dTninow(ix1,ix2,ix3)=Tn     ! assign saved temperature into correct slot in "output" variables
        end do
      end do
    end do
  end subroutine rotate_winds

  !> destructor for when object goes out of scope
  subroutine dissociate_neutral2D_pointers(self)
    class(neutraldata2D) :: self

    ! deallocate arrays from base inputdata class
    call self%dissociate_pointers()

    ! null pointers specific to parent neutraldata class
    call self%dissociate_neutral_pointers()

    ! now deallocate arrays specific to this extension
    deallocate(self%proj_ezp_e1,self%proj_ezp_e2,self%proj_ezp_e3)
    deallocate(self%proj_ehorzp_e1,self%proj_ehorzp_e2,self%proj_ehorzp_e3)
    deallocate(self%horzimat,self%zimat)

    ! set pointers to null
    nullify(self%horzi,self%zi);
    nullify(self%horzn,self%zn);
    nullify(self%dnO,self%dnN2,self%dnO2,self%dvnz,self%dvnhorz,self%dTn)
  end subroutine dissociate_neutral2D_pointers
end module neutraldata2Dobj


	SUBROUTINE IM_HRNIDH  ( imgfil, ihdr, iret )
C************************************************************************
C* IM_HRNIDH								*
C*									*
C* This subroutine parses the header information from a raw Higher      *
C* Resolution NIDS file	and sets the navigation.			*
C*									*
C* IM_HRNIDH  ( IMGFIL, IHDR, IRET )					*
C*									*
C* Input parameters:							*
C*	IMGFIL		CHAR		Image file name			*
C*	IHDR (39)	INTEGER		HR NIDS header information	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -4 = Invalid image product	*
C*					 -5 = Invalid image navigation	*
C*                                                                      *
C* High Res Data Files Supported by this routine:                       *
C 32 = DHR
C 94 = N0Q
C 99 = N0U
C 134 = DVL
C 135 = EET
C 138 = DSP
C
C * Full high res product list
C*      32 DHR                                                          *
C*      81 DPA
C*      93 ??
C*      94 N0U,N1U,...
C*      99 N0Q,N1Q,...
C*      134 DVL
C*      135 EET
C*      138 DSP
C*      153 ??
C*      154 ??
C*      155 ??
C*      194 ??
C*      195 ??
C*      199 ??
C**									*
C* Log:									*
C* X. Guo/CWS           05/10   Copy from IM_NIDH                       *
C* M. James/Unidata     07/11   Removed down-sampling to 8-bit          *
C* M. James/Unidata     01/14   Fixed reflectivity scale and flagged    *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'IMGDEF.CMN'
	INCLUDE		'AREAFL.CMN'
C*
	CHARACTER*(*)	imgfil
	INTEGER 	ihdr (39)
C*
	BYTE     	ibarr (36)
	INTEGER		idtarr (3), idlvls (16)
	INTEGER*2	iarr2 (78), ivtim2 (2),  ibzsiz2 (2)
	INTEGER*4	inhead (39), ivtim4, ibzsiz4, bzarr(9)
        REAL*4          fphead (39)
	CHARACTER       prdnam*8, units*8, desc*20
	INTEGER		dmask, dscale, doffs, tmask
C*
        EQUIVALENCE     (inhead, iarr2)
	EQUIVALENCE	(ivtim4, ivtim2)
	EQUIVALENCE	(ibzsiz4, ibzsiz2)
	EQUIVALENCE	(bzarr, ibarr)
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the header array into the local array variable.
C
        DO  i = 1, 39
            inhead (i) = ihdr (i)
        END DO
C
C*      Determine whether file needs bytes flipped. If so, swap and save
C*      the four byte data values before flipping each two-byte pair.
C*      The time variable crosses a word boundary, so treat it specially.
C
        IF ( (iarr2 (1) .gt. 255) .or. (iarr2 (1) .lt. 0) ) THEN
            CALL MV_SWP4 ( 1, inhead (3), imlenf )
            CALL MV_SWP4 ( 1, inhead (6), iradlt )
            CALL MV_SWP4 ( 1, inhead (7), iradln )
            CALL MV_SWP4 ( 1, inhead (28), isymof )
            CALL MV_SWP4 ( 1, inhead (29), igrfof )
            CALL MV_SWP4 ( 1, inhead (30), itabof )
            CALL MV_SWP4 ( 1, inhead (34), idllen )
            CALL MV_SWP4 ( 39, inhead, fphead )
            CALL MV_SWP2 ( 39, inhead, inhead )
            ivtim2 (1) = iarr2 (23)
            ivtim2 (2) = iarr2 (22)
            ivtime = ivtim4
            ibzsiz2 (1) = iarr2 (53)
            ibzsiz2 (2) = iarr2 (52)
            ibzsiz = ibzsiz4
            imbswp = 1
        ELSE
            iradlt = inhead (6)
            iradln = inhead (7)
            isymof = inhead (28)
            idllen = inhead (34)
            ivtim2 (1) = iarr2 (22)
            ivtim2 (2) = iarr2 (23)
            ivtime = ivtim4
            imbswp = 0
        END IF

C
C*      Fill 2-byte variables
C
        iprod  = iarr2 (16)
	immode = iarr2 (17)
C
C*      If equal 0 (maintenance mode), do not need to process
C
        IF ( immode .eq. 0 ) THEN
            iret = -4
            RETURN
        END IF
        ivdate = iarr2 (21)
        ipd3   = iarr2 (30)
        ipd8   = iarr2 (51)

        IF ( ipd8 .eq. 1 ) THEN
           nbret = 36
           CALL IM_BZSEC ( imgfil, ibzsiz, imprsz, isymof, ibarr,
     +       nbret, ier)
           IF ( ier .eq. 0 ) THEN
              DO i=1,9
                 inhead(30+i) = bzarr(i)
              END DO
              IF ( imbswp .eq. 1 ) THEN
                  CALL MV_SWP4 ( 1, inhead (34), idllen )
                  CALL MV_SWP2 ( 9, inhead(31), inhead(31) )
              ELSE
                  idllen = inhead(34)
              END IF
           END IF
        END IF

	DO i = 1, 16
           idlvls (i) = iarr2 (30 + i)
        END DO
C
        ipkcd1 = iarr2 (69)
C
C*      Check for the current higher resolution pack code
C
        IF ( ipkcd1 .ne. 16 ) THEN
            iret = -4
            RETURN
        END IF
C
C*	Radial product-specific variables
C
	nrbins = iarr2 (71)
C
        imnpix = nrbins * 2
        imnlin = imnpix
        imrdfl = -1
        imdoff = isymof * 2
        imldat = idllen
C
C*	Set product info
C
	imsorc = 7
	imdpth = 1
	imtype = iprod
	isrc   = iarr2 (7)
	CALL TB_NIDS  ( isrc, imtype, prdnam, nlev, units, res, desc,
     +			ierr )
	IF  ( ierr .ne. 0 )  THEN
	    CALL ER_WMSG ( 'TB', ierr, ' ', ier )
	    iret = -4
	    RETURN
	END IF
	CALL ST_RNUL(prdnam, prdnam, lens, ier )
	CALL ST_RNUL(units, units, lens, ier )
	CALL ST_RNUL(desc, desc, lens, ier )
C
C*	Set image calibration (units)
C
	cmcalb = 'RAW '
C
C*	Save radar beam elevation angle for base products
C
	IF ( (imtype .eq. 94) .or. (imtype .eq. 99) .or.
     +        (imtype .eq. 134) .or. (imtype .eq. 135)) THEN
	    rmbelv = ipd3 * 0.1
	ELSE
	    rmbelv = RMISSD
	END IF
C
C*	Determine date. Date stored with the raw data is the number of
C*	days from 1/1/70. Put it into YYYYMMDD form.
C
	nyear = (ivdate - 1 + .5) / 365.25
	jyear = 1970 + nyear
	jday  = ivdate - INT (nyear * 365.25 + .25)
	CALL TI_JTOI ( jyear, jday, idtarr, ier )
	imdate =  idtarr (1) * 10000 + idtarr (2) * 100 + idtarr (3)
C
C*	Time stored is number of seconds past UTC midnight. Put it into
C*	HHMMSS form. Use volume scan time.
C
	imtime = (10000 * (ivtime / 3600)) + (100 * MOD (ivtime/60,60))
     +		 + MOD (ivtime,60)
C
C*	Build data level values
C
	imndlv = nlev
	cmbunt = units
C
	IF ( iprod .eq. 138 ) THEN
	   amin = idlvls ( 1 ) / 100.
	   ainc = idlvls ( 2 ) / 100.
	ELSE
	   amin = idlvls ( 1 ) / 10.
	   ainc = idlvls ( 2 ) / 10.
	END IF

        SELECT CASE (iprod)
           CASE (134)
C      DVL
C
C*        0 = below threshold
C*        1 = flagged
C*        2-254 = kg/m^2
C*        255 reserved
C
              CALL short_ieee(idlvls(1), fscale)
              CALL short_ieee(idlvls(2), foffset)
              flogstart = float(idlvls(3))
              CALL short_ieee(idlvls(4), flogscale)
              CALL short_ieee(idlvls(5), flogoffset)
              DO i = 1,nlev
                 cmblev ( i ) = ''
              END DO
              DO idl = 1,nlev
                 IF ( ( idl - 1 ) .lt. flogstart ) THEN
                    fval = ( (idl - 1 ) - foffset ) / fscale
                 ELSE
                    fval = idl - 1
                    fval = exp( ( fval - flogoffset ) / flogscale)
                 ENDIF
                 CALL ST_RLCH ( fval, 2, cmblev (idl), ier )
              END DO
              cmblev(1) = 'ND'
              imndlv = nlev
           CASE (32,94,99)
C    32 = DHR
C    94 = digital reflectivity (N0Q)
C    99 = digital velocity
C
C*      8-bit reflectivity
C*      0 = missing data = -9999
C*      1 = flagged data = -9999
C*      2-255 = dBZ values
C
C*      for idl = 1, imndlv, imndlv = 256,
C*      so begin at idl = 3
C
              DO idl = 1, imndlv
                 IF ( idl .eq. 1 ) THEN
                    cmblev (idl) = 'ND'
                 ELSE IF ( idl .gt. 2 ) THEN
                    val  = amin + ( idl - 3 ) * ainc
                    CALL ST_RLCH ( val, 2, cmblev (idl), ier )
                 END IF
              END DO
           CASE (135)
C       135 = EET Enhanced Echo Tops
C halfword 31 contains the DATA_MASK 127 or 0x7f (hex) identifying the
C    data bits
C halfword 32 contains the DATA_SCALE 1
C halfword 33 contains the DATA_OFFSET 2
C halfword 34 contains the TOPPED_MASK 128 or 0x80
C
              DO i = 1,nlev
                 cmblev ( i ) = ''
              END DO
              dmask = idlvls ( 1 )
              dscal = idlvls ( 2 )
              doffs = idlvls ( 3 )
              tmask = idlvls ( 4 )
              DO idl = 2,71
                 val = ( IAND( idl , dmask ) / dscal ) - doffs
                 CALL ST_INCH ( int(val), cmblev (idl), ier )
              END DO
              DO idl = 130,199
                 val = ( IAND( idl , dmask ) / dscal ) - doffs
                 CALL ST_INCH ( int(val), cmblev (idl), ier )
              END DO
              CALL ST_INCH ( int(70), cmblev (199), ier )
              CALL ST_INCH ( int(70), cmblev (71), ier )
              cmblev ( 130 ) = 'TOP'
           CASE (138)
C
C*      138 = DSP
C
C*      0 = no accumulation
C* for max accumulation =< 2.55
C*      1-255 = accumulation in steps of 0.01 inches
C* for max accumulation > 2.55 and =< 5.10
C*      1-255 = accumulation in steps of 0.02 inches
C* for max accumulation > 5.10 and =< 7.65
C*      1-255 = accumulation in steps of 0.03 inches
C*      and so on...
C
C*      this is a to-do
              iinc = imndlv / 16.
              DO idl = 1, imndlv
                 val = amin + ( idl - 1 ) * ainc
C                 IF ( MOD ( ( idl - 1 ), iinc ) .eq. 0 ) THEN
                    CALL ST_RLCH ( val, 2, cmblev ( idl ), ier )
C                 ELSE
C                    cmblev ( idl ) = ' '
C                 END IF
              END DO
              cmblev ( 1 ) = 'ND'
           CASE DEFAULT
C       OTHER
C
	      DO idl = 1, imndlv
                 IF ( idl .eq. 1 ) THEN
                    cmblev (idl) = 'ND'
                 ELSE
                    val = amin + ( idl - 1 ) * ainc
                    CALL ST_RLCH ( val, 1, cmblev (idl), ier )
                 END IF
	      END DO
	END SELECT
C
C*	Set image subset bound to whole image right now.
C
	imleft = 1
	imtop  = 1
	imrght = imnpix
	imbot  = imnlin
C
	iadir (6)  = 1
	iadir (7)  = 1
	iadir (12) = 1
	iadir (13) = 1

	CALL ST_CTOI ( 'RADR', 1, ianav (1), ier )
	ianav (2)  = imnlin / 2
	ianav (3)  = imnpix / 2
C
C*	Convert floating point lat/lon to DDDMMSS format
C
	deg = ABS ( iradlt * .001)
	ideg = INT ( deg * 100000 )
	idec = MOD ( ideg, 100000 )
	irem = (idec * 3600 + 50000 ) / 100000

	idms = ( ideg / 100000 + irem / 3600 ) * 10000 +
     +	         MOD (irem, 3600) / 60 * 100 + MOD (irem, 60)
	IF ( iradlt .lt. 0 ) idms = -idms
	ianav (4)  = idms

	deg = ABS ( iradln * .001)
	ideg = INT ( deg * 100000 )
	idec = MOD ( ideg, 100000 )
	irem = (idec * 3600 + 50000 ) / 100000

	idms = ( ideg / 100000 + irem / 3600 ) * 10000 +
     +		MOD (irem, 3600) / 60 * 100 + MOD (irem, 60)
C
C*	Set west lon (neg) to match MCIDAS west lon (pos)
C
	IF ( iradln .gt. 0 ) idms = -idms
	ianav (5)  = idms

	ianav (6)  = res * 1000
	ianav (7)  = 0
	ianav (8)  = 0

	CALL GSATMG ( imgfil, iadir, ianav, imleft, imtop, imrght,
     +			  imbot, ier )
C
	IF ( ier .ne. 0 ) iret = -5
C
	RETURN
	END


c###settxr.for
      SUBROUTINE SETTXR
c***********************************************
c          Alex Shovkoplyas made some changes to:
c             curmuf
c             seltxr
c             settxr
c             sigdis
c          Normally if the version (..\database\version.w32)
c             is yy.mmddW then the original version is used.
c                yy.mmddA then Alex's version is used.
c***********************************************
      use cversn
c      common /CVERSN/ VERSN
c      character VERSN*8
      if(versn(8:8).eq.'A' .or. versn(8:8).eq.'a') then
         call settxr_alex       !  use Alex's modified version
      else
         call settxr_orig       !  use original version
      end if
      return
      end
C--------------------------------
      SUBROUTINE SETTXR_orig
C--------------------------------
C------------ SUBROUTINES SETRCR AND SETTMT COMBINED  1/10/91 FJR
C
C     THIS SUBROUTINE CALCULATES THE LOSSES, ETC. FOR ALL
C     MODES AT THE TRANSMITTER/RECEIVER END
C
      COMMON / CONTRL / IELECT(3), KTOUT(12), MONTHS(12), SUNSP(12),
     A IANTOU, ICARD, INTEG, IRED, ISOUT, ISPROC, ISSN, ITYPE, JDASH,
     B JFREQ, JLONG, KCARD, KRUN, MAPIN, MAXNAM, MONOLD, MOREM, MORES,
     C NUMNAM, NUPROC, MAXMET, MSPEC, M100
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON/CON/D2R,DCL,GAMA,PI,PI2,PIO2,R2D,RZ,VOFL
      COMMON/ES/FS(3,5),HS(5)
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON/GEOG/GYZ(5),RAT(5),GMDIP(5),CLCK(5),ABIY(5),ARTIC(5),SIGPAT
     A (5),EPSPAT(5)
      COMMON/LOSX/ANDVX(45,3),ADVX(45,3),AOFX(45,3),ARFX(45,3),GRLOSX(45
     A ,3),TGAINX(45,3),TLSKM(45,3),EFFlp(45),IAFTXR(3)
      COMMON/MUFS/EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24)
     A ,ALLMUF(24),FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4)
     B ,SIGU(4),DELMUF(4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4)
     C ,YFOT(4),YHPF(4),YMUF(4)
      COMMON/SIGD/DSL,ASM,DSU,AGLAT,DSLF,ASMF,DSUF,ACAV,FEAV,AFE,BFE,HNU
     A ,HTLOSS,XNUZ,XVE
      COMMON/RAYS/ANG(40),IFOB(40,30,5),NANG
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON / allMODE /ABPS(20),CREL(20),FLDST(20),HN(20),HP(20),
     1PROB(20),RELY(20),RGAIN(20),SIGPOW(20),SN(20),
     2SPRO(20),TGAIN(20),TIMED(20),TLOSS(20),B(20),FSLOS(20),
     3grlos(20),adv(20),obf(20),
     CNMODE(20),TLLOW(20),TLHGH(20),EFF(20),NREL,NMMOD
C125PC      common/lpalmcmp/imddl(45,2,11,24,4,2),igdfx(45,2,11,24,4,2),
C125PC     +itlos(45,2,11,24,4,2),ihpfx(45,2,11,24,4,2),lNANG(2,11,24,4,2)
C125PC      integer*2 imddl,igdfx,itlos,ihpfx,lNANG
      COMMON/INFORM/INFO,IHSHR,IHLNG
C125PC      COMMON/INDICEZ/ISP,ISZ,IFQN,IUR,NMS(11,24,4,2)
c----------------------------------------------------------------
C.....FOR MAX. NUMBER OF HOPS
      DEND = AMIN1(4000.,GCDKM)
ccc      write(12,'(''amind='',f10.5)') amind
      DO 1000 JJ=1,2
      ILN=0
      K = ITXRCP(JJ)
      DO 10 IA=1,45
      GML(IA,K)=-999.
   10 FHP(IA,K)=999.
      DO 80 IA = 1,45
C.....DOES THE MODE EXIST (QUESTION MARK)
      IF(HPFLX(IA,K) - 70. ) 90,75,75
C.....NUMBER OF HOPS
   75 XHPM = DEND/GDFLX(IA,K)
C.....MUST HAVE AT LEAST ONE FOR SHORT PATHS
      IF( XHPM - 0.9) 80, 76, 76
   76 IF(DELFX(IA,K) - AMIND) 80, 95, 95
   80 CONTINUE
   90 CONTINUE
C  PENETRATED LAYER, TRY OVER THE MUF MODE.
C.....SO IF NONE FAILS, INCLUDE OVER-THE-MUF
      IM = MODMUF
      DELFX(1,K) = DELMUF(IM)
      HPFLX(1,K) = HPMUF (IM)
      HTFLX(1,K) = HTMUF (IM)
      FVFLX(1,K) = FVMUF (IM)
      AFFLX(1,K) = AFMUF (IM)
      XHOP = NHOPMF(IM)
      GDFLX(1,K) = GCDKM/XHOP
      IMODE(1,K) = MODMUF
   95 CONTINUE
      BC = (FREQ+ GYZ(K))**1.98
      AC = 677.2*ABIY(K)
      DO 250 IA = 1,45
C.....PRESET ARRAYS
      TGAINX(IA,K) = -10.
      ANDVX(IA,K) = 1000.
      ADVX (IA,K) = 1000.
      GRLOSX(IA,K) = 0.0
C.....MODE GOOD (QUESTION MARK)  ONE IS.
ccc      write(12,14) ia,k,hpflx(ia,k),delfx(ia,k)
ccc14    format('ia,k,hpflx,delfx=',2i5,2f10.4)
      IF(HPFLX(IA,K).lt.70.) go to 250
C.....CHECK FOR MINIMUM
      IF(DELFX(IA,K).lt.AMIND) go to 250
      DEL = DELFX(IA,K) * D2R      !  radiation angle
      CDEL = COS(DEL)
C.....E MODE (QUESTION MARK)
      IF(FI(1,K).lt.FVFLX(IA,K) ) go to 125
C  D-E  LAYER MODES.
C.....VERY LOW REFLECTIONS (QUESTION MARK)
      IF(HTLOSS.le.HTFLX(IA,K)) then
         XNSQ = 10.2
      else
         HNUX = 61.+ 3.*(HTFLX(IA,K)- 70.)/18.
C.....COLLISION FREQUENCY
         XNSQ = XNUZ * EXP(-2.*(HNUX -60.)/HNU)
      end if
      HEFF = AMIN1(100.,HTFLX(IA,K))
      SINP = RZ* CDEL/(RZ+ HEFF)
      SECP = 1./SQRT(1.- SINP*SINP)
C.....ABSORPTION LOSS
      ANDVX(IA,K)= SECP *AC /(BC +XNSQ)
      XV = AMAX1(FVFLX(IA,K)/FI(1,K) , XVE)
C.....CORRECTION FOR E LAYER
      ADX= AFE + BFE* ALOG(XV)
      SINP = RZ*CDEL/(RZ +HPFLX(IA,K))
      SECP = 1./SQRT(1.-SINP*SINP)
C.....DEVIATIVE LOSS + CORRECTION
      ADVX(IA,K) = SECP*AFFLX(IA,K)*( ( FVFLX(IA,K)+GYZ(K))**1.98 +XNSQ)
     A            /(BC+ XNSQ)   +ADX
C.....ES OBSCURATION, NONE
      AOFX(IA,K) = 0.0
      GO TO 160
C  F LAYER MODES
  125 CONTINUE
      XNSQ = 10.2
      SINP = RZ*CDEL/(RZ +100.)
      SECP = 1./SQRT(1. -SINP*SINP)
C.....ABSORPTION LOSS
      ANDVX(IA,K) = SECP*AC/(BC+ XNSQ)
      SINP = RZ* CDEL/(RZ +HPFLX(IA,K))
      SECP = 1./SQRT(1. -SINP*SINP)
C.....DEVIATIVE LOSS
      ADVX(IA,K) = SECP*AFFLX(IA,K)*((FVFLX(IA,K)+GYZ(K))**1.98 +XNSQ)
     A            /(BC+ XNSQ)
C  ES OBSCURTION LOSS
      AOFX(IA,K) =0.0
C.....SPORADIC E EXISTS (QUESTION MARK)
      IF(FS(2,K).le.0.) go to 160
      FSDEAD =IFOB(1,3,K)
      FSDEAD =FSDEAD/1000.
      FMHZ = AMAX1(FREQ,FSDEAD)
      SINS = RZ*CDEL/(RZ + HS(K) )
      SECS = 1./SQRT(1.-SINS*SINS)
C.....MUF THIS DISTANCE
      ESD  = FS(2,K)*SECS
      DUMMY = YMUF(4)
      P = PRBMUF(FMHZ,ESD,DUMMY,4)
      P = AMAX1(.1,P)
      P = AMIN1(.9,P)
C.....OBSCURATION
      AOFX(IA,K) = -10.*ALOG10(1.-P)
  160 CONTINUE
C GROUND LOSS
      Y = 0.0
      DO 170 IG = 1,KM
      IGX = -IG
      CALL GAIN(IGX,DEL,FREQ,YG,GEFF)
  170 Y = Y + YG
      XKM = KM
C.....AVERAGE GROUND LOSS
      GRLOSX(IA,K) = Y / XKM
C ANTENNA GAINS
C125PC      IF(MSPEC.EQ.125)THEN
C125PC        TGAINX(IA,K) =0.
C125PC      ELSE
        CALL GAIN(JJ,DEL,FREQ,Y,TEFF)
        TGAINX(IA,K) =Y
        if(JJ.eq.2)EFFlp(ia)=TEFF
C125PC      ENDIF
      SPHET = RZ * CDEL / (RZ + HTFLX(IA,K))
      CPHET = 1.-SPHET*SPHET
      CPHET = AMAX1(0.00000001,CPHET)
      CPHET = SQRT(CPHET)
C-----?????????????????
      IS = IMODE(IA,K)
      IS = MODMUF
C-----?????????????????
      DUMMY = YMUF(IS)
      PROS = PRBMUF(FREQ,DUMMY,DUMMY,IS)
C.....OVER-THE-MUF, MEDIAN
      XLS = -10.*ALOG10(PROS)/CPHET
      IF(IAND(INFO,2).GT.0)THEN
        XLSWO=XLS*CPHET
        WRITE(99,'(2(A,I2),A,2F7.2,A,2F7.2)')' "SETTXR" LAY=',IS,
     1'  IA=',IA,'  FRQ,YMUF=',FREQ,DUMMY,'   MD OTMs,OTM=',XLS,
     2  XLSWO
      ENDIF
C ADD ADJUSTMENT TO ABSORPTION LOSS
      ANDVX(IA,K) = ANDVX(IA,K) + XLS
      PROB(JJ) = PROS
      ILN=ILN+1
C125PC      IF(MSPEC.EQ.125)THEN
C125PC      itlos(ILN,JJ,IFQN,IUR,ISZ,ISP)=(andvx(ia,k)+advx(ia,k)+.05)*10.
C125PC      imod=IMODE(ia,k)
C125PC      imddl(ILN,JJ,IFQN,IUR,ISZ,ISP)=imod*10000+(delfx(ia,k)+.05)*10.
C125PC      ihpfx(ILN,JJ,IFQN,IUR,ISZ,ISP)=(hpflx(ia,k)+.05)*10.
C125PC      igdfx(ILN,JJ,IFQN,IUR,ISZ,ISP)=(GDFLX(IA,K)+.5)
C125PC      ENDIF
  250 CONTINUE
C125PC      IF(MSPEC.EQ.125)LNANG(JJ,IFQN,IUR,ISZ,ISP)=ILN
 1000 CONTINUE
      RETURN
      END
C--------------------------------
c###settxr.for
      SUBROUTINE SETTXR_alex
C--------------------------------
C------------ SUBROUTINES SETRCR AND SETTMT COMBINED  1/10/91 FJR
C
C     THIS SUBROUTINE CALCULATES THE LOSSES, ETC. FOR ALL
C     MODES AT THE TRANSMITTER/RECEIVER END
C
      COMMON / CONTRL / IELECT(3), KTOUT(12), MONTHS(12), SUNSP(12),
     A IANTOU, ICARD, INTEG, IRED, ISOUT, ISPROC, ISSN, ITYPE, JDASH,
     B JFREQ, JLONG, KCARD, KRUN, MAPIN, MAXNAM, MONOLD, MOREM, MORES,
     C NUMNAM, NUPROC, MAXMET, MSPEC, M100
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON/CON/D2R,DCL,GAMA,PI,PI2,PIO2,R2D,RZ,VOFL
      COMMON/ES/FS(3,5),HS(5)
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON/GEOG/GYZ(5),RAT(5),GMDIP(5),CLCK(5),ABIY(5),ARTIC(5),SIGPAT
     A (5),EPSPAT(5)
      COMMON/LOSX/ANDVX(45,3),ADVX(45,3),AOFX(45,3),ARFX(45,3),GRLOSX(45
     A ,3),TGAINX(45,3),TLSKM(45,3),EFFlp(45),IAFTXR(3)
      COMMON/MUFS/EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24)
     A ,ALLMUF(24),FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4)
     B ,SIGU(4),DELMUF(4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4)
     C ,YFOT(4),YHPF(4),YMUF(4)
      COMMON/SIGD/DSL,ASM,DSU,AGLAT,DSLF,ASMF,DSUF,ACAV,FEAV,AFE,BFE,HNU
     A ,HTLOSS,XNUZ,XVE
      COMMON/RAYS/ANG(40),IFOB(40,30,5),NANG
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON / allMODE /ABPS(20),CREL(20),FLDST(20),HN(20),HP(20),
     1PROB(20),RELY(20),RGAIN(20),SIGPOW(20),SN(20),
     2SPRO(20),TGAIN(20),TIMED(20),TLOSS(20),B(20),FSLOS(20),
     3grlos(20),adv(20),obf(20),
     CNMODE(20),TLLOW(20),TLHGH(20),EFF(20),NREL,NMMOD
C125PC      common/lpalmcmp/imddl(45,2,11,24,4,2),igdfx(45,2,11,24,4,2),
C125PC     +itlos(45,2,11,24,4,2),ihpfx(45,2,11,24,4,2),lNANG(2,11,24,4,2)
C125PC      integer*2 imddl,igdfx,itlos,ihpfx,lNANG
      COMMON/INFORM/INFO,IHSHR,IHLNG
C125PC      COMMON/INDICEZ/ISP,ISZ,IFQN,IUR,NMS(11,24,4,2)
c----------------------------------------------------------------
c>>>>>A.S.
      DIMENSION LX(3)
      DATA LX/1,3,5/
      LOGICAL FOUND
c<<<<<
C.....FOR MAX. NUMBER OF HOPS
      DEND = AMIN1(4000.,GCDKM)
ccc      write(12,'(''amind='',f10.5)') amind
      DO 1000 JJ=1,2
      ILN=0
      K = ITXRCP(JJ)
      DO 10 IA=1,45
      GML(IA,K)=-999.
   10 FHP(IA,K)=999.

c>>>>>A.S.
c     check if any good modes exist
c     mark bad modes with HPFLX = 0
      FOUND = .FALSE.
      DO 80 IA = 1,45
      IF(IA .GT. IAFTXR(K)) GOTO 75                  !end of HPFLX reached
      IF(HPFLX(IA,K) .LT. 70) GOTO 75                !end of HPFLX reached
      IF(DELFX(IA,K) .LT. AMIND) GOTO 75             !below the minimum angle
      IF((DEND/GDFLX(IA,K) - 0.9) .LT. 0) GOTO 75    !less than one hop
c     good mode
      FOUND = .TRUE.
      GOTO 80
c     bad mode
   75 HPFLX(IA,K) = 0
   80 CONTINUE
      if (FOUND) GOTO 95
c<<<<<
C  PENETRATED LAYER, TRY OVER THE MUF MODE.
C.....SO IF NONE FAILS, INCLUDE OVER-THE-MUF
      IM = MODMUF
      DELFX(1,K) = DELMUF(IM)
      HPFLX(1,K) = HPMUF (IM)
      HTFLX(1,K) = HTMUF (IM)
      FVFLX(1,K) = FVMUF (IM)
      AFFLX(1,K) = AFMUF (IM)
      XHOP = NHOPMF(IM)
      GDFLX(1,K) = GCDKM/XHOP
      IMODE(1,K) = MODMUF
   95 CONTINUE
c>>>>>A.S.
      BC = (FREQ+ GYZ(LX(K)))**1.98
c<<<<<
      AC = 677.2*ABIY(K)
      DO 250 IA = 1,45
C.....PRESET ARRAYS
      TGAINX(IA,K) = -10.
      ANDVX(IA,K) = 1000.
      ADVX (IA,K) = 1000.
      GRLOSX(IA,K) = 0.0
C.....MODE GOOD (QUESTION MARK)  ONE IS.
ccc      write(12,14) ia,k,hpflx(ia,k),delfx(ia,k)
ccc14    format('ia,k,hpflx,delfx=',2i5,2f10.4)
      IF(HPFLX(IA,K).lt.70.) go to 250
C.....CHECK FOR MINIMUM
c>>>>>A.S.
c      this line was causing problems and has been removed
c      no need to check DELFX
c      since all bad modes now have HPFLX = 0
c      IF(DELFX(IA,K).lt.AMIND) go to 250
c<<<<<
      DEL = DELFX(IA,K) * D2R      !  radiation angle
      CDEL = COS(DEL)
C.....E MODE (QUESTION MARK)
      IF(FI(1,K).lt.FVFLX(IA,K) ) go to 125
C  D-E  LAYER MODES.
C.....VERY LOW REFLECTIONS (QUESTION MARK)
      IF(HTLOSS.le.HTFLX(IA,K)) then
         XNSQ = 10.2
      else
         HNUX = 61.+ 3.*(HTFLX(IA,K)- 70.)/18.
C.....COLLISION FREQUENCY
         XNSQ = XNUZ * EXP(-2.*(HNUX -60.)/HNU)
      end if
      HEFF = AMIN1(100.,HTFLX(IA,K))
      SINP = RZ* CDEL/(RZ+ HEFF)
      SECP = 1./SQRT(1.- SINP*SINP)
C.....ABSORPTION LOSS
      ANDVX(IA,K)= SECP *AC /(BC +XNSQ)
      XV = AMAX1(FVFLX(IA,K)/FI(1,K) , XVE)
C.....CORRECTION FOR E LAYER
      ADX= AFE + BFE* ALOG(XV)
      SINP = RZ*CDEL/(RZ +HPFLX(IA,K))
      SECP = 1./SQRT(1.-SINP*SINP)
C.....DEVIATIVE LOSS + CORRECTION
c>>>>>A.S.
      ADVX(IA,K) = SECP*AFFLX(IA,K)*( ( FVFLX(IA,K)+GYZ(LX(K)))**1.98
     A +XNSQ) /(BC+ XNSQ)   +ADX
c<<<<<
C.....ES OBSCURATION, NONE
      AOFX(IA,K) = 0.0
      GO TO 160
C  F LAYER MODES
  125 CONTINUE
      XNSQ = 10.2
      SINP = RZ*CDEL/(RZ +100.)
      SECP = 1./SQRT(1. -SINP*SINP)
C.....ABSORPTION LOSS
      ANDVX(IA,K) = SECP*AC/(BC+ XNSQ)
      SINP = RZ* CDEL/(RZ +HPFLX(IA,K))
      SECP = 1./SQRT(1. -SINP*SINP)
C.....DEVIATIVE LOSS
c>>>>>A.S.
      ADVX(IA,K) = SECP*AFFLX(IA,K)*((FVFLX(IA,K)+GYZ(LX(K)))**1.98
     A +XNSQ)/(BC+ XNSQ)
c<<<<<
C  ES OBSCURTION LOSS
      AOFX(IA,K) =0.0
C.....SPORADIC E EXISTS (QUESTION MARK)
      IF(FS(2,K).le.0.) go to 160
      FSDEAD =IFOB(1,3,K)
      FSDEAD =FSDEAD/1000.
      FMHZ = AMAX1(FREQ,FSDEAD)
      SINS = RZ*CDEL/(RZ + HS(K) )
      SECS = 1./SQRT(1.-SINS*SINS)
C.....MUF THIS DISTANCE
      ESD  = FS(2,K)*SECS
      DUMMY = YMUF(4)
      P = PRBMUF(FMHZ,ESD,DUMMY,4)
      P = AMAX1(.1,P)
      P = AMIN1(.9,P)
C.....OBSCURATION
      AOFX(IA,K) = -10.*ALOG10(1.-P)
  160 CONTINUE
C GROUND LOSS
      Y = 0.0
      DO 170 IG = 1,KM
      IGX = -IG
      CALL GAIN(IGX,DEL,FREQ,YG,GEFF)
  170 Y = Y + YG
      XKM = KM
C.....AVERAGE GROUND LOSS
      GRLOSX(IA,K) = Y / XKM
C ANTENNA GAINS
C125PC      IF(MSPEC.EQ.125)THEN
C125PC        TGAINX(IA,K) =0.
C125PC      ELSE
        CALL GAIN(JJ,DEL,FREQ,Y,TEFF)
        TGAINX(IA,K) =Y
        if(JJ.eq.2)EFFlp(ia)=TEFF
C125PC      ENDIF
      SPHET = RZ * CDEL / (RZ + HTFLX(IA,K))
      CPHET = 1.-SPHET*SPHET
      CPHET = AMAX1(0.00000001,CPHET)
      CPHET = SQRT(CPHET)
C-----?????????????????
      IS = IMODE(IA,K)
      IS = MODMUF
C-----?????????????????
      DUMMY = YMUF(IS)
      PROS = PRBMUF(FREQ,DUMMY,DUMMY,IS)
C.....OVER-THE-MUF, MEDIAN
      XLS = -10.*ALOG10(PROS)/CPHET
      IF(IAND(INFO,2).GT.0)THEN
        XLSWO=XLS*CPHET
        WRITE(99,'(2(A,I2),A,2F7.2,A,2F7.2)')' "SETTXR" LAY=',IS,
     1'  IA=',IA,'  FRQ,YMUF=',FREQ,DUMMY,'   MD OTMs,OTM=',XLS,
     2  XLSWO
      ENDIF
C ADD ADJUSTMENT TO ABSORPTION LOSS
      ANDVX(IA,K) = ANDVX(IA,K) + XLS
      PROB(JJ) = PROS
      ILN=ILN+1
C125PC      IF(MSPEC.EQ.125)THEN
C125PC      itlos(ILN,JJ,IFQN,IUR,ISZ,ISP)=(andvx(ia,k)+advx(ia,k)+.05)*10.
C125PC      imod=IMODE(ia,k)
C125PC      imddl(ILN,JJ,IFQN,IUR,ISZ,ISP)=imod*10000+(delfx(ia,k)+.05)*10.
C125PC      ihpfx(ILN,JJ,IFQN,IUR,ISZ,ISP)=(hpflx(ia,k)+.05)*10.
C125PC      igdfx(ILN,JJ,IFQN,IUR,ISZ,ISP)=(GDFLX(IA,K)+.5)
C125PC      ENDIF
  250 CONTINUE
C125PC      IF(MSPEC.EQ.125)LNANG(JJ,IFQN,IUR,ISZ,ISP)=ILN
 1000 CONTINUE
      RETURN
      END
C--------------------------------


module efielddataobj

! type extension for file-based electric field data input.  Assumes parallel communication between root/workers for data
! distribution.  An interesting aspect of this object is that it is/may never be used by anyone but root who initiates the
! calls to MUMPS and boundary conditions.

use, intrinsic :: ieee_arithmetic, only: ieee_is_finite
use phys_consts, only: wp,debug,pi,Re
use inputdataobj, only: inputdata
use meshobj, only: curvmesh
use config, only: gemini_cfg
use reader, only: get_simsize2,get_grid2,get_efield
!! note that only root uses this data object since this concerns the potential solver
use timeutils, only: dateinc,date_filename
use grid, only: lx1,lx2,lx2all,lx3,lx3all,gridflag

implicit none (type, external)
public :: efielddata

type, extends(inputdata) :: efielddata
  ! coordinate for input precipitation data, and storage
  real(wp), dimension(:), pointer :: mlonp,mlatp
  integer, pointer :: llon,llat

  ! named pointers for ease of use with external programs
  real(wp), pointer :: flagdirich      ! this will need to be converted to integer at some point because all datasets are floating point here
  real(wp), dimension(:,:), pointer :: E0xp,E0yp
  real(wp), dimension(:,:), pointer :: Vminx1p,Vmaxx1p
  real(wp), dimension(:), pointer :: Vminx2pslice,Vmaxx2pslice    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3pslice,Vmaxx3pslice

  real(wp), dimension(:,:), pointer :: E0xiprev,E0yiprev
  real(wp), dimension(:,:), pointer :: Vminx1iprev,Vmaxx1iprev
  real(wp), dimension(:), pointer :: Vminx2isprev,Vmaxx2isprev    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isprev,Vmaxx3isprev

  real(wp), dimension(:,:), pointer :: E0xinext,E0yinext
  real(wp), dimension(:,:), pointer :: Vminx1inext,Vmaxx1inext
  real(wp), dimension(:), pointer :: Vminx2isnext,Vmaxx2isnext    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isnext,Vmaxx3isnext

  real(wp), dimension(:,:), pointer :: E0xinow,E0yinow
  real(wp), dimension(:,:), pointer :: Vminx1inow,Vmaxx1inow
  real(wp), dimension(:), pointer :: Vminx2isnow,Vmaxx2isnow    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isnow,Vmaxx3isnow
  contains
    ! overriding procedures
    procedure :: set_sizes=>set_sizes_efield

    ! deferred bindings
    procedure :: init=>init_efield
    procedure :: set_coordsi=>set_coordsi_efield
    procedure :: load_data=>load_data_efield
    procedure :: load_grid=>load_grid_efield
    procedure :: load_size=>load_size_efield
    final :: destructor
end type efielddata

contains
  !> need to override set_sizes so to account for fact that target interpolation is to a 2D grid, by default object will
  !    assume 3D and get the sizes from the simulation grid
  subroutine set_sizes_efield(self, &
                     l0D, &
                     l1Dax1,l1Dax2,l1Dax3, &
                     l2Dax23,l2Dax12,l2Dax13, &
                     l3D, &
                     x)
    class(efielddata), intent(inout) :: self
    integer, intent(in) :: l0D
    integer, intent(in) :: l1Dax1,l1Dax2,l1Dax3
    integer, intent(in) :: l2Dax23,l2Dax12,l2Dax13
    integer, intent(in) :: l3D
    class(curvmesh), intent(in) :: x        ! sizes for interpolation sites taken from grid

    ! Note:  these should be set by load_data deferred procedure
    ! coordinate axis sizes for input data
    !self%lc1=lc1; self%lc2=lc2; self%lc3=lc3;
    if (.not. self%flagdatasize) error stop 'inpudata:set_sizes() - must set input datasize first using load_size()'

    ! number of different types of data
    self%l0D=l0D
    self%l1Dax1=l1Dax1; self%l1Dax2=l1Dax2; self%l1Dax3=l1Dax3;
    self%l2Dax23=l2Dax23; self%l2Dax12=l2Dax12; self%l2Dax13=l2Dax13;
    self%l3D=l3D

    ! coordinate axis sizes for interpolation states; noting that for a dipole we (internally) permute
    !   the interpolation sites in the same sense.
    !select type (x)
    !  class is (dipolemesh)
    !    print*, ' efielddata:  detected dipole mesh'
    !    self%lc1i=x%lx1;       ! note this dataset has 1D and 2D target interpolation grid
    !    self%lc2i=x%lx3all; self%lc3i=x%lx2all;
    !    ! dipolemesh mesh permuted ~alt,lat,lon, whereas inputdata organized lon,lat
    !  class default
        self%lc1i=x%lx1;       ! note this dataset has 1D and 2D target interpolation grid
        self%lc2i=x%lx2all; self%lc3i=x%lx3all;
    !end select

    ! check that the user is trying something sensible
    !if (self%lc1==1 .and. self%lc1i/=1 .or. self%lc2==1 .and. self%lc2i/=1 &
    !        .or. self%lc3==1 .and. self%lc3i/=1) then
    !  error stop 'inputdata:set_sizes() - singleton dimensions must be same for source and destination.'
    !end if

    ! flag sizes as assigned
    self%flagsizes=.true.
  end subroutine set_sizes_efield

  !> set pointers to appropriate data arrays (taking into account dimensionality of the problem) and prime everything
  !    so we are ready to call self%update()
  !  After this procedure is called all pointer aliases are set and can be used; internal to this procedure pay attention
  !  to ordering of when pointers are set with respect to when various type-bound procedures are called
  subroutine init_efield(self,cfg,sourcedir,x,dtmodel,dtdata,ymd,UTsec)
    class(efielddata), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg                 ! gemini config type for optional params
    character(*), intent(in) :: sourcedir    ! directory for precipitation data input
    class(curvmesh), intent(in) :: x                    ! curvmesh object
    real(wp), intent(in) :: dtmodel,dtdata                      ! model time step and cadence for input data from config.nml
    integer, dimension(3), intent(in) :: ymd            ! target date of initiation
    real(wp), intent(in) :: UTsec                       ! target time of initiation
    character(:), allocatable :: strname

    ! tell our object where its data are and give the dataset a name
    call self%set_source(sourcedir)
    strname='electric field boundary conditions'
    call self%set_name(strname)
    self%flagdoinput=cfg%flagE0file/=0

    ! read the simulation size from the source directory and allocate arrays
    allocate(self%lc1,self%lc2,self%lc3)      ! these are pointers
    self%llon=>self%lc2; self%llat=>self%lc3;
    call self%load_size()
    call self%set_sizes(1, &
                       0,2,2, &
                       4,0,0, &
                       0, &
                       x )
    call self%init_storage()
    call self%set_cadence(dtdata)

    ! set local pointers grid pointers and assign input data grid
    self%mlonp=>self%coord2; self%mlatp=>self%coord3;
    call self%load_grid()

    ! set input data array pointers to faciliate easy to read input code
    self%flagdirich=>self%data0D(1)
    self%E0xp=>self%data2Dax23(:,:,1)
    self%E0yp=>self%data2Dax23(:,:,2)
    self%Vminx1p=>self%data2Dax23(:,:,3)
    self%Vmaxx1p=>self%data2Dax23(:,:,4)
    self%Vminx2pslice=>self%data1Dax3(:,1)
    self%Vmaxx2pslice=>self%data1Dax3(:,2)
    self%Vminx3pslice=>self%data1Dax2(:,1)
    self%Vmaxx3pslice=>self%data1Dax2(:,2)

    self%E0xiprev=>self%data2Dax23i(:,:,1,1)
    self%E0yiprev=>self%data2Dax23i(:,:,2,1)
    self%Vminx1iprev=>self%data2Dax23i(:,:,3,1)
    self%Vmaxx1iprev=>self%data2Dax23i(:,:,4,1)
    self%Vminx2isprev=>self%data1Dax3i(:,1,1)
    self%Vmaxx2isprev=>self%data1Dax3i(:,2,1)
    self%Vminx3isprev=>self%data1Dax2i(:,1,1)
    self%Vmaxx3isprev=>self%data1Dax2i(:,2,1)

    self%E0xinext=>self%data2Dax23i(:,:,1,2)
    self%E0yinext=>self%data2Dax23i(:,:,2,2)
    self%Vminx1inext=>self%data2Dax23i(:,:,3,2)
    self%Vmaxx1inext=>self%data2Dax23i(:,:,4,2)
    self%Vminx2isnext=>self%data1Dax3i(:,1,2)
    self%Vmaxx2isnext=>self%data1Dax3i(:,2,2)
    self%Vminx3isnext=>self%data1Dax2i(:,1,2)
    self%Vmaxx3isnext=>self%data1Dax2i(:,2,2)

    self%E0xinow=>self%data2Dax23inow(:,:,1)
    self%E0yinow=>self%data2Dax23inow(:,:,2)
    self%Vminx1inow=>self%data2Dax23inow(:,:,3)
    self%Vmaxx1inow=>self%data2Dax23inow(:,:,4)
    self%Vminx2isnow=>self%data1Dax3inow(:,1)
    self%Vmaxx2isnow=>self%data1Dax3inow(:,2)
    self%Vminx3isnow=>self%data1Dax2inow(:,1)
    self%Vmaxx3isnow=>self%data1Dax2inow(:,2)

    ! initialize the prev variables sensibly
    self%E0xiprev=0.0
    self%E0yiprev=0.0
    self%Vminx1iprev=0.0
    self%Vmaxx1iprev=0.0
    self%Vminx2isprev=0.0
    self%Vmaxx2isprev=0.0
    self%Vminx3isprev=0.0
    self%Vmaxx3isprev=0.0

    ! set to start time of simulation - set the first time update is called
    !self%ymdref(:,1)=cfg%ymd0; self%ymdref(:,2)=cfg%ymd0;
    !self%UTsecref(1)=cfg%UTsec0; self%UTsecref(2)=cfg%UTsec0;

    ! prime input data
    print*, 'Preparing to prime input data arrays...'
    call self%prime_data(cfg,x,dtmodel,ymd,UTsec)
  end subroutine init_efield

  !> get the input grid size from file, all workers will just call this sicne this is a one-time thing
  subroutine load_size_efield(self)
    class(efielddata), intent(inout) :: self

    ! basic error checking
    if (.not. self%flagsource) error stop 'efielddata:load_size_precip() - must define a source directory first'

    ! read sizes
    print '(/,A,/,A)', 'Electric field input:','--------------------'
    print '(A)', 'READ electric field size from: ' // self%sourcedir
    call get_simsize2(self%sourcedir, llon=self%llon, llat=self%llat)

    print '(A,2I6)', 'Electric field size: llon,llat:  ',self%llon,self%llat
    if (self%llon < 1 .or. self%llat < 1) then
     print*, '  efielddata grid size must be strictly positive: ' //  self%sourcedir
     error stop
    end if

    ! set dim 1 size to null since inherently not used
    self%lc1=0

    ! flag to denote input data size is set
    self%flagdatasize=.true.
  end subroutine load_size_efield

  !> get the grid information from a file, all workers will just call this since one-time
  subroutine load_grid_efield(self)
    class(efielddata), intent(inout) :: self

    ! read grid data
    call get_grid2(self%sourcedir, self%mlonp, self%mlatp)

    print '(A,4F9.3)', 'Electric field mlon,mlat extent:  ',minval(self%mlonp(:)),maxval(self%mlonp(:)), &
                                                           minval(self%mlatp(:)),maxval(self%mlatp(:))
    if(.not. all(ieee_is_finite(self%mlonp))) error stop 'efielddata:loadgrid() - mlon must be finite'
    if(.not. all(ieee_is_finite(self%mlatp))) error stop 'efielddata:loadgrid() - mlat must be finite'
  end subroutine load_grid_efield

  subroutine set_coordsi_efield(self,cfg,x)
    class(efielddata), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg     ! presently not used but possibly eventually?
    class(curvmesh), intent(in) :: x
    integer :: ix2,ix3,iflat,ix1ref,ix2ref,ix3ref

    print*, shape(self%coord1i),shape(self%coord2i),shape(self%coord3i)

    !! reference locations for determining points onto which we are interpolating
    !! these are grid specific, not object specific...
    if (x%lx2all > 1 .and. x%lx3all>1) then ! 3D sim
      ix2ref = x%lx2all/2      !note integer division
      ix3ref = x%lx3all/2
    else if (x%lx2all==1 .and. x%lx3all>1) then
      ix2ref = 1
      ix3ref=x%lx3all/2
    else if (x%lx2all>1 .and. x%lx3all==1) then
      ix2ref=x%lx2all/2
      ix3ref=1
    else
      error stop 'Unable to orient boundary conditions for electric potential'
    endif

    !! by default the code uses 300km altitude as a reference location, using the center x2,x3 point
    !! These are the coordinates for inputs varying along axes 2,3
    ix1ref = minloc(abs(x%rall(:,ix2ref,ix3ref) - Re - 300e3_wp), dim=1)
    do ix3=1,lx3all
      do ix2=1,lx2all
        iflat=(ix3-1)*lx2all+ix2
        self%coord2iax23(iflat)=x%phiall(ix1ref,ix2,ix3)*180/pi
        self%coord3iax23(iflat)=90-x%thetaall(ix1ref,ix2,ix3)*180/pi
      end do
    end do
    if (debug) print '(A,4F7.2)', 'Grid has mlon,mlat range:  ',minval(self%coord2iax23),maxval(self%coord2iax23), &
                                     minval(self%coord3iax23),maxval(self%coord3iax23)
    if (debug) print *, 'Grid has size:  ',iflat

    if (self%flagdipmesh) then
      !! for electric field input data we also have some things that vary along axis 3 only
      do ix2=1,x%lx2all    ! note mangling ix2->ix3
        self%coord3iax3(ix2)=90-x%thetaall(ix1ref,ix2,1)*180/pi     ! default to ix2=1 side of the grid
      end do
      !! for BCs varing along axis 2 only
      do ix3=1,x%lx3all    ! note mangling ix3->ix2
        self%coord2iax2(ix3)=x%phiall(ix1ref,1,ix3)*180/pi          ! default to ix3=1 side of the grid
      end do
    else
      !! for electric field input data we also have some things that vary along axis 3 only
      do ix3=1,x%lx3all
        self%coord3iax3(ix3)=90-x%thetaall(ix1ref,1,ix3)*180/pi     ! default to ix2=1 side of the grid
      end do
      !! for BCs varing along axis 2 only
      do ix2=1,x%lx2all
        self%coord2iax2(ix2)=x%phiall(ix1ref,ix2,1)*180/pi          ! default to ix3=1 side of the grid
      end do
    end if

    !! mark coordinates as set
    self%flagcoordsi=.true.
  end subroutine set_coordsi_efield

  !> have root read in data from a file (only root manipulates this object)
  subroutine load_data_efield(self,t,dtmodel,ymdtmp,UTsectmp)
    class(efielddata), intent(inout) :: self
    real(wp), intent(in) :: t,dtmodel
    integer, dimension(3), intent(inout) :: ymdtmp
    real(wp), intent(inout) :: UTsectmp
    integer :: iid,ierr
    integer :: flagdirich_int

    !! all workers should update the date
    ymdtmp = self%ymdref(:,2)
    UTsectmp = self%UTsecref(2)
    call dateinc(self%dt, ymdtmp, UTsectmp)

    !! all workers read data out of this file
    print*, '  date and time:  ',ymdtmp,UTsectmp
    print*, '  efield filename:  ',date_filename(self%sourcedir,ymdtmp,UTsectmp)

    call get_Efield(date_filename(self%sourcedir, ymdtmp, UTsectmp), &
      flagdirich_int,self%E0xp,self%E0yp,self%Vminx1p,self%Vmaxx1p,&
      self%Vminx2pslice,self%Vmaxx2pslice,self%Vminx3pslice,self%Vmaxx3pslice)
    self%flagdirich=real(flagdirich_int,wp)

    if (debug) then
      print*, ' Solve type:  ', self%flagdirich
      print *, 'Min/max values for E0xp:  ',minval(self%E0xp),maxval(self%E0xp)
      print *, 'Min/max values for E0yp:  ',minval(self%E0yp),maxval(self%E0yp)
      print *, 'Min/max values for Vminx1p:  ',minval(self%Vminx1p),maxval(self%Vminx1p)
      print *, 'Min/max values for Vmaxx1p:  ',minval(self%Vmaxx1p),maxval(self%Vmaxx1p)
      print *, 'Min/max values for Vminx2pslice:  ',minval(self%Vminx2pslice),maxval(self%Vminx2pslice)
      print *, 'Min/max values for Vmaxx2pslice:  ',minval(self%Vmaxx2pslice),maxval(self%Vmaxx2pslice)
      print *, 'Min/max values for Vminx3pslice:  ',minval(self%Vminx3pslice),maxval(self%Vminx3pslice)
      print *, 'Min/max values for Vmaxx3pslice:  ',minval(self%Vmaxx3pslice),maxval(self%Vmaxx3pslice)
    endif

    if (.not. all(ieee_is_finite(self%E0xp))) error stop 'E0xp: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%E0yp))) error stop 'E0yp: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx1p))) error stop 'Vminx1p: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx1p))) error stop 'Vmaxx1p: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx2pslice))) error stop 'Vminx2pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx2pslice))) error stop 'Vmaxx2pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx3pslice))) error stop 'Vminx3pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx3pslice))) error stop 'Vmaxx3pslice: non-finite value(s)'
  end subroutine load_data_efield

  !> destructor needs to clear memory out
  subroutine destructor(self)
    type(efielddata), intent(inout) :: self

    call self%dissociate_pointers()
  end subroutine destructor
end module efielddataobj