subroutine read_satmar (nread, ndata, nodata,                                 &
                        infile, obstype, lunout, gstime, twind, sis,          &
                        nobs  )
!
!subroutine read_goesimg(mype,val_img,ithin,rmesh,jsatid,gstime,&
!     infile,lunout,obstype,nread,ndata,nodata,twind,sis, &
!     mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs, &
!     nrec_start,dval_use)
! *#* Documentation block - Start *#*
!
! =>  Subroutine read_satmar        :     Reads Hs from Altimeters
! =>  Coder                         :     stelios flampouris - stylianos.flampouris@noaa.gov
! => Abstract                       :
!      1. This routine reads data from CNES and OCEANAVO:
!      OCEANAVO: xx114 (NC031114) // xx120 (NC031120) // xx121 (NC031121) // xx127 (NC031127) // xx130 (NC031130)
!      CNES    : xx115 (NC031115) // xx122 (NC031122) // xx123 (NC031123) // xx124 (NC031124)
!
!      DATA SET      |     Corresponding Satellite
!      xx114, xx115  |     JASON-2
!      xx120, xx123  |     CRYOSAT-2
!      xx121, xx122  |     SARAL/ATK
!      xx124, xx127  |     JASON-3
!      xx130         |     SENTINEL3a
!
!      2. It uses the provided flags for QC.
!      3. Observations only within the domain of interest are retained.
!
!      For reading the data of interest, the "headers" (hdr_ variables) have to be
!      modified accordingly; in this case, Significant Wave Height (howv or hs) data are
!      imported.
!
! => History log                    :
! 2016.03.07      :     stelios flampouris
! 2017.05.03      :     pondeca: add c_station_id and set station id to "SATMAR"
!                                for now
! 2017.08.07      :     stelios: 1. The data from CNES and OCEANAVO can be used.
!                 :              2. The c_station_id is variable and gets the
!                 input from the "subset" according to the values given at the
!                 datasets when dumped at the tanks.
! 2017.08.12      :     stelios: Imports Sentinel3a howv obs
! 2017.10.01      :     jacob  : Fix bug
! 2017.10.23      :     stelios: Keep unique data
!
!   input argument list:
!     ithin    - flag to thin data
!     rmesh    - thinning mesh size (km)
!     gstime   - analysis time in minutes from reference date
!     infile   - unit from which to read BUFR data
!     lunout   - unit to which to write data for further processing
!     obstype  - observation type to process
!     twind    - input group time window (hours)
!     sis      - satellite/instrument/sensor indicator
!
!   output argument list:
!     nread    - number of obs read
!     ndata    - number of obs retained for further processing
!     nodata   - number of obs retained for further processing
!     nobs     - array of observations on each subdomain for each processor
!
! => Attributes                     :
!     language: f90
!
! *#* Documentation block - End  *#*
!
! *#* Variables Declaration - Start *#*
   use kinds, only: r_kind,r_double,i_kind
   use gsi_4dvar, only: l4dvar,l4densvar,winlen,iwinbgn,thin4d,time_4dvar
   use constants, only: zero, deg2rad,rad2deg,one,two,three,four,ten,half, &
       r60inv,r60,r3600,tiny_r_kind !,init_constants_derived
   use gridmod, only: regional, rlats,rlons,nlat,nlon,txy2ll,tll2xy, &
       twodvar_regional
   use satthin, only: map2tgrid,destroygrids,makegrids
   use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind
   use convthin, only: make3grids,use_all,map3grids,del3grids
   use obsmod, only: bmiss,hilbert_curve
   use mpimod, only: npe

   implicit none
!
!! %%% Declare passed variables IN
   integer(i_kind)                     , intent(in) :: lunout
   character(len=*)                    , intent(in) :: infile, obstype
   real(r_kind)                        , intent(in) :: gstime,twind
!! %%%% Declare Passed Variables INOUT
   integer(i_kind)                     , intent(inout) :: nread,ndata,nodata
   integer(i_kind),dimension(npe)      , intent(inout) :: nobs
!! %%% Declare local varables
!  integer
   integer(i_kind) :: ithin
   integer(i_kind),parameter  :: lun11 = 11
   integer(i_kind),parameter  :: nosat =  9
   integer(i_kind),parameter  :: n_tm  =  6
   integer(i_kind),parameter  :: n_lc  =  2
   integer(i_kind),parameter  :: n_howv=  2
   integer(i_kind),parameter  :: dtLen =  10
   integer(i_kind),parameter  :: nreal =  23
   real   (r_kind),parameter  :: r90   =  90.0_r_kind
   real   (r_kind),parameter  :: r6    =  6.0_r_kind
   real   (r_kind),parameter :: dflt_err = 0.2_r_kind
!
   integer(i_kind) :: tot,cnt,cnt1,k,ntmp,iout,iiout
   integer(i_kind) :: ireadmg,ireadsb,idate
   integer(i_kind) :: iRec,ierr,nc,i1,ilat,ilon,nchanl,nlevp,indsat
   integer(i_kind) :: nmind, nrec
   integer(i_kind) :: thisobtype_usage, iuse
!  real
   real(r_kind),allocatable,dimension(:, :) :: data_all,data_out
   real(r_kind),allocatable,dimension(:):: DumForThin
   integer(i_kind),allocatable,dimension(:):: isort,iloc
!   real(r_kind),allocatable,dimension(:   ) :: data_1d
   real(r_kind) :: dlon,dlat
   real(r_kind) :: tdiff,crit1,timedif,toff
   !
   real(r_kind) :: nsec, rminobs
   real(r_kind) :: dlon_earth,dlat_earth
   real(r_kind) :: depth,usage
   real(r_kind) :: rmesh,xmesh
!   real(r_kind),dimension(1,1):: r_prvstg,r_sprvstg
!  character
   character(len=20),dimension(nosat) :: namesat
   character(len=20) :: sis
   character(len=20) :: subset
   character(len=11), parameter :: myname='read_satmar '
!  logical
   logical outside, luse
   logical lhilbert
   logical, dimension(nosat) :: satuse
!!!! #####     JS2      ##### !!!!
   integer(i_kind),parameter  :: n_fltJS2 = 7
!
   real(r_double), dimension (n_fltJS2)  :: flt_1dJS2
   real(r_double), dimension (n_tm)   :: time_1d
   integer(i_kind), dimension (n_tm-1) :: time_1dMN
   real(r_double), dimension (n_lc)   :: loc_1d
   real(r_double), dimension (n_howv) :: howv_1d
   real(r_kind) :: t4dv
   character(80),parameter:: hdr_fltJS2   = 'RSST AETP ASFL ADQF ALRF IPIN ODLE'
   character(80),parameter:: hdr_time  = 'YEAR MNTH DAYS HOUR MINU SECW'
!   character(80),parameter:: hdr_loc   = 'CLATH CLONH'
   character(80)  :: hdr_loc
   character(80),parameter:: hdr_howvJS2  = 'KBSW RKSW ' !CBSW RCSW'
!!!! #####     SARAL    ##### !!!!
   integer(i_kind),parameter  :: n_fltSAL = 5
!
   real(r_double), dimension (n_fltSAL)  :: flt_1dSAL
   !
   character(80),parameter:: hdr_fltSAL = 'RSST BSADQF NVPSWH IPIN ODLE'
   character(80),parameter:: hdr_howvSAL  = 'SBSWH RMSSWH'
!!!! #####     CS2    ##### !!!!
   integer(i_kind),parameter  :: n_fltCS2 = 5
   integer(i_kind),parameter  :: n_howvCS2 = 4
!
   real(r_double), dimension (n_fltCS2)  :: flt_1dCS2
!   real(r_kind), dimension (n_howvCS2) :: howv_1dCS2
!
   integer(i_kind),parameter  :: n_howvNO = 2   !NO
!
   character(80),parameter:: hdr_timeCS2  = 'YEAR MNTH DAYS HOUR MINU SECO'
   character(80),parameter:: hdr_fltCS2   = 'DSST ODLE L1PQ L1PF L2PF'
   character(80),parameter:: hdr_howvCS2  = 'KBSW NVPK2'
!   character(80),parameter:: hdr_howvCS2  = 'KBSW NVPK2 SBSW SWHS '
   character(80),parameter:: hdr_howvNO  = 'HOWV SDWH'   !NO
!
   character(80),parameter::hdr_station = 'SAID'
   real(r_double) :: rstation_id
   character(8) c_station_id
!
   equivalence(rstation_id,c_station_id)
! Swords
   integer(i_kind),parameter :: howvMax = 12
   integer(i_kind),parameter :: howvRatMiuSigma = 3
   integer(i_kind),parameter :: howvRathowvDpth = 2
   real(r_kind),parameter    :: howvDistm = 10000.0_r_kind
!
!   call init_constants_derived
   lhilbert = twodvar_regional .and. hilbert_curve
   namesat(1:nosat) = (/'NC031115','NC031122','NC031123','NC031127' &
                       ,'NC031114','NC031121','NC031120','NC031124' &
                       ,'NC031130'                                  /)

   satuse(1:nosat) = .true.
   tot = 0
   cnt = 0
   irec = 0
   cnt1 = 0
   nchanl=0
   nread = 0
   ilon=2
   ilat=3
   nrec = 0
!
   ithin=-9
   nc=zero
   conv: do i1=1,nconvtype
      if(trim(obstype) == trim(ioctype(i1)) .and. ictype(i1)==547) then
         nc=i1
         exit conv
      end if
   end do conv
   if(nc == 0)then
      write(6,*) myname,' no matching obstype found in convinfo ',obstype
      return
   end if
!
!  *#* Thinning *#*!
  use_all = .true.
  ithin=ithin_conv(nc)
  if (ithin > 0 ) then
     rmesh=rmesh_conv(nc)
     use_all = .false.
     nlevp=1   !Dummy for using make3grids
     allocate(DumForThin(nlevp)) !Dummy for using make3grids
     xmesh=rmesh
     call make3grids(xmesh,nlevp)
     write(6,'(A,1x,A,1x,A,I4,1x,f8.2,1x,I3,1x,I3)')myname,': ioctype(nc),ictype(nc),rmesh,nlevp,nc ',&
                 trim(ioctype(nc)),ictype(nc),rmesh,nlevp,nc
  endif
!
!  *#* Main - Start *#*!
   call closbf(lun11)
   open(lun11,file=trim(infile),action='read',form='unformatted', iostat=ierr)
   if (ierr/=0) then
      print*, myname,' : ERROR : File ', trim(infile),' not existing. '
      return
   end if
!
   call openbf(lun11,'IN',lun11)
!
!  Counting all the data
   do while(ireadmg(lun11,subset,idate) == 0)
      do while (ireadsb(lun11) == 0)
         cnt = cnt+1
         if(cnt == 1) call time_4dvar(idate,toff)
      end do
   end do
   call closbf(lun11)
!
! Allocate Arrays for all the data
   allocate (data_all (nreal, cnt),isort(cnt))
   isort = 0
!
!  Loop over file
   open(lun11,file=trim(infile),action='read',form='unformatted')
   call openbf(lun11,'IN',lun11)
   call datelen(dtLen)
!
   read_msg: do while(ireadmg(lun11,subset,idate) == 0)
      do i1 = 1,nosat
         if (index(trim(subset),trim(namesat(i1))) > 0) then
            indsat=i1
            exit
         end if
      end do
      if ( .not.satuse(indsat) ) cycle
!
!     Read through each record
      read_loop: do while (ireadsb(lun11) == 0)
         nrec = nrec + 1
!
         time_1d  = zero
         howv_1d  = zero
         loc_1d   = zero
         depth    = -99999.0_r_kind
!
         if (     (index(trim(subset),trim(namesat(1))) > 0)      &              !JS2
             .or. (index(trim(subset),trim(namesat(4))) > 0)      ) then         !JS4
!            sis = namesat(1)
            call ufbint(lun11,flt_1dJS2,n_fltJS2,1,irec,hdr_fltJS2)
!  Qc flags
            if (  (flt_1dJS2(1)>1.0_r_double)  .or. &
                  (flt_1dJS2(2)/=0.0_r_double)  .or. &
                  (flt_1dJS2(3)/=0.0_r_double)  .or. &
                  (flt_1dJS2(4)/=0.0_r_double)  .or. &
                  (flt_1dJS2(5)/=0.0_r_double)  .or. &
                  (flt_1dJS2(6)/=0.0_r_double)       )    cycle

            depth = abs(flt_1dJS2(7))
!  Time
            call ufbint(lun11,time_1d,n_tm,1,irec,hdr_time)
!  Howv
            call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvJS2)
            hdr_loc   = 'CLATH CLONH'
!
         else if   (index(trim(subset),trim(namesat(2)))>0) then                 !SRLTK
!            sis = namesat(2)
            call ufbint(lun11,flt_1dSAL,n_fltSAL,1,irec,hdr_fltSAL)
            if ( (flt_1dSAL(1)>1.0_r_double ) .or.   &
                 (flt_1dSAL(2)/=0.0_r_double) .or.   &
                 (flt_1dSAL(3)<=30.0_r_double) .or.   &
                 (flt_1dSAL(4)/=0.0_r_double )        ) cycle

            depth = abs(flt_1dSAL(5))
!  Time
            call ufbint(lun11,time_1d,n_tm,1,irec,hdr_time)
!  Howv
            call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvSAL)
!
            hdr_loc   = 'CLATH CLONH'
         else if   (index(trim(subset),trim(namesat(3)))>0) then                 !CS2
!            sis=namesat(3)
            call ufbint(lun11,flt_1dCS2,n_fltCS2,1,irec,hdr_fltCS2)
            if ( (flt_1dCS2(1) > 1.0_r_double    ) .or.   &
                 (flt_1dCS2(2) > 0.0_r_double    ) .or.   &
                 (flt_1dCS2(3) < 90.0_r_double   ) .or.   &
                 (flt_1dCS2(4) /= 0.0_r_double   ) .or.   &
                 (flt_1dCS2(5) /= 0.0_r_double   )        ) cycle
!
            depth = abs(flt_1dCS2(2))
!  Time
            call ufbint(lun11,time_1d,n_tm,1,irec,hdr_timeCS2)
!  Howv
            call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvCS2)
            howv_1d(2)=zero
!
            hdr_loc   = 'CLATH CLONH'
          else if(  (index(trim(subset),trim(namesat(5))) > 0)  &
                .or.(index(trim(subset),trim(namesat(6))) > 0)  &
                .or.(index(trim(subset),trim(namesat(7))) > 0)  &
                .or.(index(trim(subset),trim(namesat(8))) > 0)  &
                .or.(index(trim(subset),trim(namesat(9))) > 0)  ) then       !NO
!  Time
            call ufbint(lun11,time_1d,n_tm,1,irec,hdr_timeCS2)
!  Howv
            call ufbint(lun11,howv_1d,n_howv,1,irec,hdr_howvNO)
!
            hdr_loc   = 'CLAT CLON  '
         end if
!  Temporal space
         time_1dMN = int(time_1d(1:5))
         call w3fs21(time_1dMN, nmind)
!
         rminobs=real(nmind,r_double)+(real(time_1d(6),r_double)*r60inv)
!
         t4dv = (rminobs-real(iwinbgn,r_kind))*r60inv
         tdiff=(rminobs-gstime)*r60inv
!
         if (l4dvar.or.l4densvar) then
            if (t4dv<zero .OR. t4dv>winlen) cycle
         else
            if (abs(tdiff) > ctwind(nc) .or. (abs(tdiff) > twind) )then
               cycle
            end if
         endif
!
!  Physical Space
         call ufbint(lun11,loc_1d,n_lc,1,irec,hdr_loc)
         if(abs(loc_1d(1))>r90 .or. abs(loc_1d(2))>360.0_r_kind) cycle
!
         if (loc_1d(2)>=360.0) loc_1d(2)=loc_1d(2)-360.0_r_kind
         if (loc_1d(2)< zero) loc_1d(2)=loc_1d(2)+360.0_r_kind
!
         dlon_earth=loc_1d(2)*deg2rad
         dlat_earth=loc_1d(1)*deg2rad
         nread = nread + 1
!
         if(regional)then                                            ! Regional

            call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)     ! *Convert to rotated coordinate
            if(outside) cycle

         else                                                        ! Global case
            dlon=dlon_earth
            dlat=dlat_earth
            call grdcrd1(dlat,rlats,nlat,1)
            call grdcrd1(dlon,rlons,nlon,1)
         endif
!  Slayer
         call datesec(time_1d, nsec)
         if (howv_1d(1)/=howv_1d(1)                                  ) cycle  !qc0
         if ( howv_1d(1)              > howvMax                      ) cycle  !qc1
         if ((howv_1d(2)              > zero)            .and.       &
             (howv_1d(1) / howv_1d(2) < howvRatMiuSigma)             ) cycle  !qc2
         if ((depth<=-99998.0_r_kind)    .and.       &
             (howv_1d(1) / depth)     > howvRathowvDpth              ) cycle  !qc3
! Next lines need update. #ww3
!         if (tot==one) then
!            nsec_m1 = nsec
!            loc_1d_m1 = loc_1d
!            howv_1d_m1 = howv_1d(1)
!         else if(tot>one)then
!            dt_sec = nsec-nsec_m1
!            call lldistm(loc_1d,loc_1d_m1, Hdistm, Pdistm)
!            if ( (abs(Hdistm)<howvDistm).and.(dt_sec<two) ) then
!               if (abs(howv_1d(1)-howv_1d_m1(1)) > hs_max_diff             ) cycle  !qc4
!               if (abs(howv_1d(1)-howv_1d_m1(1))/(dt_sec)**two > grav/two  ) cycle  !qc5
!            end if
!            nsec_m1 = nsec
!            loc_1d_m1 = loc_1d
!            howv_1d_m1 = howv_1d(1)
!         end if
         tot = tot+1
!
!  Dragon on Diet
         cnt = 0
         iuse=icuse(nc)
         if (ithin > 0 .and. iuse >=0) then
            ntmp=ndata
            if (thin4d) then
               timedif = zero                ! crit1=0.01_r_kind
            else
               timedif=abs(t4dv-toff)        ! timedif = 6.0_r_kind*abs(tdiff) & crit1=0.01_r_kind+timedif
            end if
            crit1 = timedif/r6+half
!
            call map3grids(-1,0,DumForThin,nlevp,dlat_earth,dlon_earth     &
                           ,one ,crit1,ndata,iout,nrec,iiout,luse,.false.,.false.)
               if (.not. luse) cycle
               if(iiout > 0) isort(iiout)=0
               if (ndata > ntmp) then
                  nodata=nodata+1
               endif
               isort(nrec)=iout
         else  ! - no thinnning
               ndata=ndata+1
               nodata=nodata+1
               iout=ndata
               isort(nrec)=iout
         endif
!
         usage = zero !-  Set usage variable :: practically useless
         if (howv_1d(2)<=tiny_r_kind) howv_1d(2)=dflt_err
!
!        call ufbint(lun11,c_station_id,1,1,irec,hdr_station)
!         c_station_id='SATMAR'
         c_station_id=trim(subset)
!
         if (index(trim(subset),trim(namesat(1))) > 0) satuse(5)=.false.
         if (index(trim(subset),trim(namesat(2))) > 0) satuse(6)=.false.
         if (index(trim(subset),trim(namesat(3))) > 0) satuse(7)=.false.
         if (index(trim(subset),trim(namesat(4))) > 0) satuse(8)=.false.
         if (index(trim(subset),trim(namesat(5))) > 0) satuse(1)=.false.
         if (index(trim(subset),trim(namesat(6))) > 0) satuse(2)=.false.
         if (index(trim(subset),trim(namesat(7))) > 0) satuse(3)=.false.
         if (index(trim(subset),trim(namesat(8))) > 0) satuse(4)=.false.

         data_all(1,iout) = howv_1d(2)                 ! significant wave height error (m)
         data_all(2,iout) = dlon                       ! grid relative longitude
         data_all(3,iout) = dlat                       ! grid relative latitude
         data_all(4,iout) = zero                       ! pressure (in cb)
         data_all(5,iout) = howv_1d(1)                 ! significant wave height (in m)
         data_all(6,iout) = rstation_id                ! station id
         data_all(7,iout) = t4dv                       ! time
         data_all(8,iout) = nc                         ! type
         data_all(9,iout) = 0_r_kind                   ! quality mark
         data_all(10,iout) = 0.2_r_kind                ! original obs error (m)
         data_all(11,iout) = usage                     ! usage parameter
         if (lhilbert) thisobtype_usage=11             ! save INDEX of where usage is stored for hilbertcurve cross validation (if requested)
         data_all(12,iout) = zero                      ! dominate surface type
         data_all(13,iout) = 295_r_kind                ! skin temperature
         data_all(14,iout) = 1.0                         ! 10 meter wind factor
         data_all(15,iout) = bmiss                     ! surface roughness
         data_all(16,iout) = dlon_earth*rad2deg        ! earth relative longitude (degrees)
         data_all(17,iout) = dlat_earth*rad2deg        ! earth relative latitude (degrees)
         data_all(18,iout) = zero                      ! station elevation (m)
         data_all(19,iout) = zero                      ! observation height (m)
         data_all(20,iout) = -depth                    ! terrain height at ob location
         data_all(21,iout) = 100000000000.000_r_kind    ! provider name !r_prvstg(1,1)
         data_all(22,iout) = 100000000000.000_r_kind    ! subprovider name !r_sprvstg(1,1)
         data_all(23,iout) = 0_r_kind                     ! cat
!
      enddo read_loop
   enddo read_msg
   call closbf(lun11)
   ! Write header record and data to output file for further processing
   allocate(iloc(ndata))
   cnt1 = 0
   do i1=1,size(data_all,2)
     if(isort(i1) > 0)then
       cnt1=cnt1 + 1
       iloc(cnt1)=isort(i1)
     end if
  end do
  if(ndata /= cnt1)then
     write(6,*) myname,': ndata and icount do not match STOPPING...ndata,cnt1,cnt ',ndata,cnt1,cnt
     call stop2(50)
  end if
!
  allocate(data_out(nreal,ndata))
  do i1=1,ndata
     iout=iloc(i1)
     do k=1,nreal
        data_out(k,i1)=data_all(k,iout)
     end do
  end do
  deallocate(iloc,isort,data_all)

  call count_obs(ndata,nreal,ilat,ilon,data_out,nobs)

  write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
  write(lunout) data_out
  deallocate(data_out)

  if (ndata == 0) then
     write(6,*)myname,':  closbf(',lun11,')'
  endif
  close(lun11)
!
! Deallocate local arrays
   if (ithin > 0 ) then
      deallocate(DumForThin)
      call del3grids
   end if
!
end subroutine read_satmar
!
! ###
subroutine lldistm(latlon1,latlon2, Hdistm, Pdistm)
! *#* Documentation block - Start *#*
! => Subroutine lldistm : Calculates the distance in m between two points in
! spherical coordinates (Earth in this case).
! => Coder              : stelios flampouris (stylianos.flampouris@noaa.gov)
! => Abstract           : Fortran code for Haversine and Pythagorian distance
!
! => History log        :
! 2016.03.08            : stelios - Prototype
! 2016.08.24            : stelios - Fully compatible with GSI
!
! => Input Arguments    : latlon1 latitude & longtitude of point 1
!                       : latlon1 latitude & longtitude of point 2
! => Output Arguments   : Hdistm Haversine distance between the point1 and point2 in meters(m)
!                       : Pdistm Pythagorian distance between the point1 and point2 in meters(m)
! => Attributes         : Machine Theia
!
! *#* Documentation block - End *#*
   use kinds, only: r_kind,r_double,i_kind
   use constants, only: one,deg2rad,rearth
   implicit none
   real(r_kind), dimension(2), intent(in) :: latlon1, latlon2
   real(r_kind), intent(out):: Hdistm, Pdistm
!local variables
   real(r_kind) :: lat1, lat2, lon1, lon2, dLat, dLon, dum1, dum2, x, y
!   integer(i_kind), parameter :: rearth=6371000 !(m)
   !
   lat1=latlon1(1)*deg2rad
   lat2=latlon2(1)*deg2rad;
   lon1=latlon1(2)*deg2rad;
   lon2=latlon2(2)*deg2rad;
   dLat=lat2-lat1;
   dLon=lon2-lon1;
!Haversine distance
   dum1=sin((dLat)/2)**2 + cos(lat1)*cos(lat2) * sin(dLon/2)**2;
   dum2=2*atan2(sqrt(dum1),sqrt(1-dum1))
   Hdistm=rearth*dum2
!Pythagoran distance
   x=dLon*cos((lat1+lat2)/2);
   y=dLat;
   Pdistm=rearth*sqrt(x*x + y*y);
!
end subroutine lldistm
!
!
!
!#### subroutine datesec(idate, nsec)
subroutine datesec(idate, nsec)
! *#* Documentation block - Start *#*
! => Subroutine datenum : Calculates the number of seconds since 00:00:00,
!    1 January 1978 (RefDate : in days)
! => Coder              : stelios flampouris (stylianos.flampouris@noaa.gov)
! => Abstract/FlowChart :
!
! [YYYY,MM,DD]-->Convert to Julian Days (JD)-->NDays=JD-Refdate-->Convert to
! Seconds (NDaysInSec)--> nsec=NDaysInSec+HH*3600+MN*60+SS
!
! => History log        :
! 2016.03.08            : stelios flampouris
!
! => Input Arguments    : idate real array with size 6:
!                         idate(1)=YYYY   !Year
!                         idate(2)=MM     !Month
!                         idate(3)=DD     !Day
!                         idate(4)=HH     !Hour
!                         idate(5)=MN     !Minute
!                         idate(6)=SS     !Second
!
! => Output Arguments   : nsec integer Number of seconds
!
! => Attributes         : Machine Theia
!
! *#* Documentation block - End *#*
!
   implicit none
   real(8), intent(in) :: idate(6)
   real(8), intent(out) :: nsec
!
! local parameters
   real(8), parameter :: ReFDate = 2443510.
   real(8) :: JD
!
! Initializing variables
   nsec = 0
   !
! Convert idate(1:3) to JD
   JD = idate(3) - 32075                                                       &
                 + 1461 * ( idate(1) + 4800 + (idate(2) - 14) / 12) / 4        &
                 +  367 * ( idate(2) - 2    - (idate(2) - 14) / 12 * 12) / 12  &
                 -    3 * ((idate(1) + 4900 + (idate(2) - 14) / 12) / 100) / 4
!
! Number of days from the reference days
   JD = JD - ReFDate
!
! Number of seconds
   nsec = (JD* 86400) + (idate(4) * 3600) + (idate(5) * 60) + idate(6)
!
end subroutine datesec
!
!
! ###
! Unused Code but Useful
!
!! ### Not necessary but implemented + All the Variables are Declared
!  ### Plug it in the "Regional Check"
!           if(diagnostic_reg) then
!              call txy2ll(dlon,dlat,dlon00,dlat00)
!              cnt1=cnt1+1
!              cdist=sin(dlat_earth)*sin(dlat00)+cos(dlat_earth)*cos(dlat00)* &
!                   (sin(dlon_earth)*sin(dlon00)+cos(dlon_earth)*cos(dlon00))
!              cdist=max(-one,min(cdist,one))
!              disterr=acos(cdist)*rad2deg
!              disterrmax=max(disterrmax,disterr)
!           end if
! ###


      subroutine steady(iflg,inflow,inflowe)
!***********************************************************************
!  Copyright, 1993, 2004,  The  Regents of the University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 Determime if steady state solution achieved
CD1
C***********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 18-OCT-93    Z. Dash        22      Add prolog.
CD2              G. Zyvoloski           Initial implementation.
CD2
CD2 $Log:   /pvcs.config/fehm90/src/steady.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:06   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:17:24   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:14:46   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:27:02   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:10:34   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:46:00 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.2   Mon Feb 05 11:30:58 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.1   03/18/94 15:55:52   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:28:18   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3   None
CD3
CD3 Interface Tables
CD3
CD3   None
CD3
CD3 Files
CD3
CD3   Name                     Use  Description
CD3
CD3   isave                    I/O  Unit number for restart file (to write)
CD3
C***********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4   None
CD4
CD4 Global Types
CD4
CD4   None
CD4
CD4 Global Variables
CD4
CD4                            COMMON
CD4   Identifier      Type     Block  Description
CD4
CD4   am0             REAL*8   faar   Initial mass in problem
CD4   ame             REAL*8   faar   ?
CD4   astmo           REAL*8   faar   Initial steam mass in problem
CD4   cord            REAL*8   fbs    Contains the coordinates of each node
CD4   deneh           REAL*8   fdd    Last time step energy accumulation term
CD4                                     at each node
CD4   denei           REAL*8   fcc    Energy accumulation term
CD4   denej           REAL*8   fdd    Last time step energy accumulation time
CD4                                     derivative at each node
CD4   denh            REAL*8   fdd    Last time step mass accumulation term at
CD4                                     each node
CD4   deni            REAL*8   fcc    Mass accumulation term
CD4   denj            REAL*8   fdd    Last time step mass accumulation time
CD4                                     derivative at each node
CD4   dstm            REAL*8   fcc    Steam mass
CD4   dtot            REAL*8   faar   Current time step size in seconds
CD4   eflow           REAL*8   fdd    Energy flow at each source node
CD4   grav            REAL*8   faar   Value of gravity
CD4   icnl            INT      faai   Problem dimension
CD4   isave           INT      faai   Unit number for restart file (to write)
CD4   ka              INT      fbb    Contains boundary type information for
CD4                                     each node
CD4   n               INT      faai   Total number of nodes
CD4   pflow           REAL*8   fdd    Flowing pressure at each source node
CD4   phi             REAL*8   fdd    Pressure at each node
CD4   phini           REAL*8   fdd2   Initial pressure at each node
CD4   pho             REAL*8   fdd    Last time step pressure at each node
CD4   pnx             REAL*8   fdd    ?Permeability in the x-direction, liquid
CD4                                     velocity in the x-direction, vapor
CD4                                     velocity in the x-direction
CD4   pny             REAL*8   fdd    ?Permeability in the y-direction liquid
CD4                                     velocity in the y direction, vapor
CD4                                     velocity in the y-direction
CD4   pnz             REAL*8   fdd    ?Permeability in the z-direction, liquid
CD4                                     velocity in the z-direction, vapor
CD4                                     velocity in the z-direction
CD4   ps              REAL*8   fdd    Porosity at each node
CD4   psini           REAL*8   fdd2   Initial porosity at each node
CD4   qflux           REAL*8   fdd    Heat flux at each node
CD4   qflxm           REAL*8   fdd    Heat flux impedance at each node
CD4   qh              REAL*8   fdd    Energy source term at each node
CD4   s               REAL*8   fdd    Liquid saturation at each node
CD4   sk              REAL*8   fdd    Source strength of each node
CD4   so              REAL*8   fdd    Last time step saturation at each node
CD4   t               REAL*8   fdd    Temperature at each node
CD4   thx             REAL*8   fdd    Thermal conductivity x-direction
CD4   thy             REAL*8   fdd    Thermal conductivity y-direction
CD4   thz             REAL*8   fdd    Thermal conductivity z-direction
CD4   tini            REAL*8   fdd2   Initial temperature at each node
CD4   to              REAL*8   fdd    Last time step temperature at each node
CD4   volume          REAL*8   fdd    Volume associated at each node
CD4   wellim          REAL*8   fdd    Well impedance at each source node
CD4
CD4 Global Subprograms
CD4
CD4   Identifier      Type     Description
CD4
CD4   bnswer                   Initiate thermodynamics and solution routines
CD4   enthp           REAL*8   Calculate enthalpy as a function of pressure
CD4                              and temperature
CD4
C***********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5   None
CD5
CD5 Local Types
CD5
CD5   None
CD5
CD5 Local variables
CD5
CD5   Identifier      Type     Description
CD5
CD5   cztop           REAL*8   Maximum coordinate
CD5   etoll           REAL*8   ?Coordinate tolerance
CD5   i               INT      Loop index
CD5   ir              INT      Problem dimension
CD5
CD5 Local Subprograms
CD5
CD5   None
CD5
C***********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
C***********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 None
CD7
C***********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8 This routine will be used in the future but is not currently
CD8 used by the code.
CD8
C***********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 Not Applicable.  See Special Comments.
CD9
C***********************************************************************

      use comai
      use combi
      use comci
      use comdi
      use comdti
      use comfi
      use comsplitts
      use comsteady
      use davidi
      implicit none

      integer i, iflg, itt
      real*8 divisor, divisore, inflow, inflowe, btol_save, tolde_save
      real*8 flow_max, ratio2, balfac1, balfac2, balfac3, balfac12
      real*8 balfac13, tol_divisor, tmch1_min, tmch1_max
      character*20 dummy
      logical null1
      parameter (tol_divisor= 1.d-8)

      if(isteady.eq.0) return
      if(iflg .eq. 0) then
c     Reading steady input parameters
         toldh = tolerance
         toldp = tolerance
         tolds = tolerance
         toldt = tolerance
         toldc = tolerance
         tolde = tolerance
         tacc = tolerance
         tol_str = tolerance
         spercent = .false.
         divisor = 1.
         divisore = 1.
         smult = 1.
         sday = 0.
         shtl = 0.0
         sdmx = 0.0
         stmch = 0.0
         balance_tol = tolerance
         tmch_old = 1.d20
         svar_flag = .false.
         sflux_flag = .false.
         info_string = 'absolute difference'
         time_ss = 1.d20
         sminstep = 2
         if (ifree .ne. 0)  then
            snstep = 150
            smult = 2.0
         else if (ico2 .lt. 0 ) then
            snstep = 500
            smult = 2.0
         else if (ico2 .eq. 0) then
            snstep = 200
            smult = 2.0
         else if (ico2 .gt. 0) then
            snstep = 200
            smult = 1.5
         end if

         do
            read (inpt, '(a80)') wdd1
            if ( null1(wdd1) .or. wdd1(1:3) .eq. 'end' ) exit
            select case (wdd1(1:4))
            case ('shea')
               read (wdd1, *) dummy, toldh
               toldp = toldh * 997. * 9.8d-6
               svar_flag = .true.
            case('spre')
               read (wdd1, *) dummy, toldp
               svar_flag = .true.
            case ('stem')
               read (wdd1, *) dummy, toldt
               svar_flag = .true.
            case('ssat')
               read (wdd1, *) dummy, tolds
               svar_flag = .true.
            case('sair')
               read (wdd1, *) dummy, toldc
               svar_flag = .true.
            case('sflu')
               read (wdd1, *) dummy, balance_tol
               sflux_flag = .true.
            case('sent')
               read (wdd1, *) dummy, tolde
               sflux_flag = .true.
            case ('stim')
               read (wdd1, *) dummy, time_ss
            case ('smul')
               read (wdd1, *) dummy, smult
            case('sday')
               read (wdd1, *) dummy, sday
            case('sdmx')
               read (wdd1, *) dummy, sdmx
            case('snst')
               read (wdd1, *) dummy, snstep
            case('smst')
               read (wdd1, *) dummy, sminstep
            case('shtl')
               read (wdd1, *) dummy, shtl
            case('sacc')
               read (wdd1, *) dummy, tacc
            case('stmc')
               read (wdd1, *) dummy, stmch
            case('smas')
               read (wdd1, *) dummy, smass
            case('tstr')
               read (wdd1, *) dummy, tol_str
            case('stss')
               read (wdd1, *) dummy, stsstr
            case('sper')
               spercent = .true.
               info_string = 'fractional change'
            end select
         end do

      else if(iflg.eq.-1) then
c 'steady macro overrides usual stopping time tims (gaz 032405)
       tims_trans = tims
       daymax_save = daymax
       tims = time_ss
       if(sdmx.gt.0.0) then
        daymax = sdmx
       else
        daymax = tims
       endif
	 daycs_save=daycs
	 daycf_save=daycf
	 dayhf_save=dayhf
	 dayhs_save=dayhs
       dayhf = 1.d50
	 dayhs = 1.d50
       daycs = 1.d50
	 day_save_ss = day
         if (sday .ne. 0) day = sday
         if (shtl .ne. 0.0) shtl0 = head_tol
         if (stmch .ne. 0.0) stmch0 = tmch
         nstep_save = nstep
         nstep = snstep
         aiaa_save = aiaa
         aiaa = smult

      else if(iflg.eq.1) then
        divisor = 1.
        divisore = 1.
        i_pdiff = 0
        pmax_i = 0.
         if (svar_flag) then
            isteady=-1
         else
            isteady = 1
            return
         endif
         if(irdof.eq.13) then
            pdifmax = 0.0
            accmax = 0.0
            accdif_i = 0
            do i = 1, n
               if (spercent) then
                  if (pho(i) .ne. 0.) then
                     divisor = pho(i)
                  else if (phi(i) .ne. 0.) then
                     divisor = phi(i)
                  else
                     divisor = 1.
                  end if
               end if
               pdifmax = max(abs((phi(i)-pho(i))/divisor),pdifmax)
c 082319 gaz
               accdif_i = abs((deni(i)*sx1(i))*dtot)
               if(accdif_i.gt.accmax) then
                i_accdif = i
                accmax = accdif_i
               endif
            end do
            if(pdifmax.gt.toldp) go to 100
            if(accmax.gt.tacc) go to 100
         else if(ico2.lt.0) then
            pdifmax = 0.0
            sdifmax = 0.0
            accmax = 0.0
            amass = 0.0
            i_pdiff = 0
            i_sdiff = 0
            i_accdif = 0
            do i = 1, n
               if (spercent) then
                  if (pho(i) .ne. 0) then
                     divisor = pho(i)
                  else if (phi(i) .ne. 0) then
                     divisor = phi(i)
                  else
                     divisor = 1.
                  end if
               end if
               pdiff_i = abs((phi(i)-pho(i))/divisor)
               if(pdiff_i.gt.pdifmax) then
                i_pdiff = i
                pmax_i = phi(i)
                pmax_io = pho(i)
                pdifmax = pdiff_i
               endif
               if (spercent) then
                     divisor = 1.
               end if
               sdiff_i = abs((s(i)-so(i))/1.)
               if(sdiff_i.gt.sdifmax) then
                i_sdiff = i
                smax_i = s(i)
                smax_io = so(i)
                sdifmax = sdiff_i
               endif
c 082319 gaz
               accdif_i = abs((deni(i)*sx1(i))*dtot)
               if(accdif_i.gt.accmax) then
                i_accdif = i
                accmax = accdif_i
               endif
            amass = amass + denh(i) * volume(i)
            end do
            if(l.eq.1) then
             amass0 = am0
             amass_ch =(amass-amass0)
             amass0 = amass
            else
             amass_ch =(amass-amass0)
             amass0 = amass
            endif
            if(pdifmax.gt.toldp) go to 100
            if(sdifmax.gt.tolds) go to 100
            if(accmax.gt.tacc) go to 100
         else if(ico2.eq.0) then
            pdifmax = 0.0
            sdifmax = 0.0
            tdifmax = 0.0
            i_accdif = 0
            accmax = 0.0
            amass = 0
            do i = 1, n
               if (spercent) then
                  if (pho(i) .ne. 0.) then
                     divisor = pho(i)
                  else if (phi(i) .ne. 0.) then
                     divisor = phi(i)
                  else
                     divisor = 1.
                  end if
               end if
               pdifmax = max(abs((phi(i)-pho(i))/divisor),pdifmax)
               if (spercent) then
                     divisor = 1.
               end if
               sdifmax = max(abs((s(i)-so(i))/1.),sdifmax)
               if (spercent) then
                  if (to(i) .ne. 0.) then
                     divisor = to(i)
                  else if (t(i) .ne. 0.) then
                     divisor = t(i)
                  else
                     divisor = 1.
                  end if
               end if
               tdifmax = max(abs((t(i)-to(i))/divisor),tdifmax)
c 082319 gaz
               accdif_i = abs((deni(i)*sx1(i))*dtot)
               if(accdif_i.gt.accmax) then
                i_accdif = i
                accmax = accdif_i
               endif
              amass = amass + denh(i) * volume(i)
            end do
            if(l.eq.1) then
             amass0 = am0
             amass_ch =(amass-amass0)
             amass0 = amass
            else
             amass_ch =(amass-amass0)
             amass0 = amass
            endif
            if(pdifmax.gt.toldp) go to 100
            if(sdifmax.gt.tolds) go to 100
            if(tdifmax.gt.toldt) go to 100
            if(accmax.gt.tacc) go to 100
         else if(ico2.gt.0) then
            pdifmax = 0.0
            sdifmax = 0.0
            tdifmax = 0.0
            pcidifmax = 0.0
            accmax = 0.0
            do i = 1, n
               if (spercent) then
                  if (pho(i) .ne. 0.) then
                     divisor = pho(i)
                  else if (phi(i) .ne. 0.) then
                     divisor = phi(i)
                  else
                     divisor = 1.
                  end if
               end if
               pdifmax = max(abs((phi(i)-pho(i))/divisor),pdifmax)
               if (spercent) then
                     divisor = 1.
               end if
               sdifmax = max(abs((s(i)-so(i))/1.),sdifmax)
               if (spercent) then
                  if (to(i) .ne. 0.) then
                     divisor = to(i)
                  else if (t(i) .ne. 0.) then
                     divisor = t(i)
                  else
                     divisor = 1.
                  end if
               end if
               tdifmax = max(abs((t(i)-to(i))/divisor),tdifmax)
               if (spercent) then
                  if (pcio(i) .ne. 0.) then
                     divisor = pcio(i)
                  else if (pci(i) .ne. 0.) then
                     divisor = pci(i)
                  else
                     divisor = 1.
                  end if
               end if
               pcidifmax = max(abs((pci(i)-pcio(i))/divisor),pcidifmax)
               accmax = max(abs(deni(i)*sx1(i)),accmax)
            end do
            if(pdifmax.gt.toldp) go to 100
            if(sdifmax.gt.tolds) go to 100
            if(tdifmax.gt.toldt) go to 100
            if(pcidifmax.gt.toldc) go to 100
            if(accmax.gt.tacc) go to 100
         endif
         isteady=1
 100     continue
      else if(iflg.eq.2) then
         if(time_ss.gt.0.0) then
	    itt = 1
         else
	    itt = 0
         endif
         if(days.ge.time_ss.and.itt.eq.1) then
            isteady = 2
            btol_save = balance_tol
            balance_tol = tolerance
            tolde_save = tolde
            tolde = tolerance
            go to 20
         endif
         if(.not. sflux_flag) then
            if (isteady .eq. 1) then
               isteady = 2
               itt = 0
            end if
            go to 10
         endif

 20      continue
         if(ico2.lt.0) then
            if (spercent) then
               if (qtoti .ne. 0) then
                  divisor = abs(qtoti)
               else if (inflow .ne. 0.) then
                  divisor = abs(inflow)
               else
                  divisor = 1.
               end if
            else
                divisor = day*8.64e4
            end if
c gaz 082819 always go through flowrate adjustment of tmch
            flow_rate = (abs(inflow) - abs(qtoti))/divisor
            if(abs(flow_rate) .le. balance_tol) then
               if(isteady.eq.-1)then
                  isteady = 1
               else if(isteady.eq.1) then
                  isteady = 2
                  itt = 0
               endif
            endif

               if (shtl.ne.0) then
c gaz 082619
c                  ratio = max(1.0d0,abs(flow_rate/balance_tol))
c                  head_tol = min(ratio*shtl0,shtl)
                   ratio = 1.
                   head_tol = min(ratio*shtl0,shtl)
               endif
               if (stmch.ne.0) then
                  flow_max = abs(flow_rate)
c                  ratio = flow_max/balance_tol
                  balfac13 = 1.5*balance_tol
                  balfac12 = 2.*balance_tol
                  balfac1 = 4*balance_tol
                  balfac2 = 100.*balance_tol
                  balfac3 = 1000.*balance_tol
                  if(flow_max.gt.balfac3.or
     &                   .days.lt.tol_str) then
                   tmch1 = 100.*stmch0
          write(ierr,*) 'balfac3 flow_max ', flow_max,' tmch1 ',tmch1
                  else if(flow_max.gt.balfac2) then
                   tmch1_min = 50.*stmch0
                   tmch1_max = 100.*stmch0
                   tmch1 = ((tmch1_max-tmch1_min)/(balfac3 -balfac2))*
     &               flow_max + tmch1_min
          write(ierr,*) 'balfac2 flow_max ', flow_max,' tmch1 ',tmch1
                  else if(flow_max.gt.balfac1) then
                   tmch1_min = 10.*stmch0
                   tmch1_max = 50.*stmch0
                   tmch1 = ((tmch1_max-tmch1_min)/(balfac2 -balfac1))*
     &               flow_max + tmch1_min
          write(ierr,*) 'balfac2 flow_max ', flow_max,' tmch1 ',tmch1
                  else if(flow_max.gt.balfac12) then
                   tmch1_min = 5.*stmch0
                   tmch1_max = 10.*stmch0
                   tmch1 = ((tmch1_max-tmch1_min)/(balfac1 -balfac12))*
     &               flow_max + tmch1_min
          write(ierr,*) 'balfac12 flow_max ', flow_max,' tmch1 ',tmch1
                  else if(flow_max.gt.balfac13) then
                   tmch1_min = 1.5*stmch0
                   tmch1_max = 5.*stmch0
                   tmch1 = ((tmch1_max-tmch1_min)/(balfac12 -balfac13))*
     &               flow_max + tmch1_min
            write(ierr,*) 'balfac13 flow_max ', flow_max,' tmch1 ',tmch1
                  else if(flow_max.gt.balance_tol) then
                   tmch1_min = stmch0
                   tmch1_max = 1.5*stmch0
                   tmch1=((tmch1_max-tmch1_min)/(balfac13-balance_tol))*
     &               flow_max + tmch1_min
            write(ierr,*) 'bal_tol flow_max ', flow_max,' tmch1 ',tmch1
                  else
                   tmch1 = stmch0
                  endif
c gaz 080519 tolerance should decrease monotonically
                  tmch = min(tmch1,tmch_old)
             write(ierr,*) ' tmch ', tmch,' tmch_old ',tmch_old
                  tmch_old = tmch
               endif
c            endif
         else if(ico2.ge.0) then
            if (spercent) then
               if (qtoti .ne. 0) then
                  divisor = abs(qtoti)
               else if (inflow .ne. 0.) then
                  divisor = abs(inflow)
               else
                  divisor = 1.
               end if
               if (qtotei .ne. 0) then
                  divisore = abs(qtotei)
               else if (inflowe .ne. 0.) then
                  divisore = abs(inflowe)
               else
                  divisore = 1.
               end if
            else
               divisor = day*8.64e4
               divisore = day*8.64e4
            end if
            flow_rate = (abs(inflow) - abs(qtoti))/divisor
            enth_rate = (abs(inflowe) - abs(qtotei))/divisore
            if(abs(flow_rate) .le. balance_tol .and.
     &           abs(enth_rate) .le. tolde) then
               if(isteady.eq.-1)then
                  isteady = 1
               else if(isteady.eq.1) then
                  isteady = 2
                  itt = 0
               endif
            else
               if (stmch.ne.0) then
                  ratio = max(1.0d0,abs(flow_rate/balance_tol),
     &                 abs(enth_rate/tolde))
                  tmch1 = min(ratio*stmch0,stmch)
                  ratio = tims/days
                  tmch2 = min(ratio*stmch0,stmch)
                  tmch = min(tmch1,tmch2)
               end if

            endif
         end if

 10      continue
         if(isteady .eq. 2) then
            if (l .lt. sminstep) then
               isteady = 1
c               return
            end if
c     If we have reached steady state or reached our maximum
c     time limit, make sure we output information
            if(itt .eq. 0) then
               if (iout .ne. 0) write(iout,50) days, trim(info_string)
               if(iptty.ne.0) write(iptty,50) days, trim(info_string)
            else
               if (iout .ne. 0) then
                  write (iout, 52) snstep, time_ss, days
                  write (iout, 53) trim(info_string)
               end if
               if(iptty.ne.0) then
                  write (iptty, 52) snstep, time_ss, days
                  write (iptty, 53) trim(info_string)
               end if
               balance_tol = btol_save
               tolde = tolde_save
            endif
         end if

         call write_steady_state

         if (isteady .eq. 2) then
            ntty = 2

            if (isty .eq. 0) then
               ifinsh = 1
               isteady = 0
               istea_pest = 1
            else
               ifinsh = 2
               isteady = 0
               tims = tims_trans
               daycs=daycs_save
               daycf=daycf_save
               dayhf=dayhf_save
               dayhs=dayhs_save
               day = day_save_ss
               daymax = daymax_save
               nstep = nstep_save
               aiaa = aiaa_save
            end if
         end if
      else if(iflg.eq.3) then
         if(isteady .ne. 2) then
            if (iout .ne. 0) write(iout,53) trim(info_string)
            if (iptty .ne. 0) write(iptty,53) trim(info_string)

            call write_steady_state

            if (iout .ne. 0) write(iout,54) snstep, time_ss, days
            if (iptty.ne.0) write(iptty,54) snstep, time_ss, days
         endif
      endif

      return

 50   format(/,'>>>>> Steady State achieved at ', g16.9,
     &     ' days (', a, ') <<<<<')
 52   format(/,'>>>>> Steady state time exceeded <<<<<',/,1p,
     &     'Max timesteps: ', i6, ' Specified Time: ',
     &     g15.6,' Simulated Time: ',g15.6)
 53   format(/,'>>>>> Steady State NOT achieved with (', a, ') <<<<<')
 54   format(/,'>>>>> Time control information <<<<<',/,1p,
     &     'Max timesteps: ', i6, ' Specified Time: ',
     &     g15.6,' Simulated Time: ',g15.6, /)
 56   format('>>>>> Total Mass ',1x,1p,g15.6
     &     'Max timesteps: ', i6, ' Specified Time: ',
     &     g15.6,' Simulated Time: ',g15.6, /)

      contains

      subroutine write_steady_state

      if (toldh .ne. tolerance)
     &     hdifmax = pdifmax /( 997. * 9.8d-6)
      if (iout .ne. 0) then
         if (isteady  .ne. 2 .and. iflg .ne. 3)
     &        write (iout, 41) trim(info_string)
         if (toldp .ne. tolerance)
     &        write(iout, 40) 'pressure', pdifmax, toldp
         if (toldp .ne. tolerance. and. i_pdiff. ne. 0)
     &        write(iout, 43) i_pdiff, pmax_i, pmax_io,izonef(i_pdiff)
         if (toldh .ne. tolerance)
     &        write(iout, 40) 'head', hdifmax, toldh
         if (tolds .ne. tolerance)
     &        write(iout, 40) 'saturation', sdifmax, tolds
         if (tolds .ne. tolerance. and. i_sdiff. ne. 0)
     &        write(iout, 44) i_sdiff, smax_i, smax_io, izonef(i_sdiff)
         if (toldt .ne. tolerance)
     &        write(iout, 40) 'temperature', tdifmax, toldt
         if (tacc .ne. tolerance)
     &        write(iout, 40) 'nodal mass', accmax, tacc
         if (tacc .ne. tolerance. and. i_accdif. ne. 0)
     &    write(iout,45)i_accdif,accmax/(sx1(i_accdif)*denh(i_accdif)),
     &            amass_ch,izonef(i_accdif)
         if (toldc .ne. tolerance)
     &        write(iout, 40) 'air pressure', pcidifmax, toldc
         if (balance_tol .ne. tolerance) write(iout, 40)
     &        'flow balance (IN-OUT)', flow_rate, balance_tol
         if (tolde .ne. tolerance) write(iout, 40)
     &        'enthalpy balance (IN-OUT)', enth_rate, tolde
            write(iout,42) tmch
         if (isty .ne. 0) write(iout,51)
      end if
      if(iptty.ne.0) then
         if (isteady .ne. 2 .and. iflg .ne. 3)
     &        write (iptty, 41) trim(info_string)
         if (toldp .ne. tolerance)
     &        write(iptty, 40) 'pressure', pdifmax, toldp
         if (toldp .ne. tolerance. and. i_pdiff. ne. 0)
     &        write(iptty, 43) i_pdiff, pmax_i, pmax_io, izonef(i_pdiff)
         if (toldh .ne. tolerance)
     &        write(iptty, 40) 'head', hdifmax, toldh
         if (tolds .ne. tolerance)
     &        write(iptty, 40) 'saturation', sdifmax, tolds
         if (tolds .ne. tolerance. and. i_sdiff. ne. 0)
     &        write(iptty, 44) i_sdiff, smax_i, smax_io, izonef(i_sdiff)
         if (toldt .ne. tolerance)
     &        write(iptty, 40) 'temperature', tdifmax, toldt
         if (tacc .ne. tolerance)
     &        write(iptty, 40) 'nodal mass', accmax, tacc
         if (tacc .ne. tolerance. and. i_accdif. ne. 0)
     &    write(iptty,45)i_accdif,accmax/(sx1(i_accdif)*denh(i_accdif)),
     &            amass_ch,izonef(i_accdif)
         if (toldc .ne. tolerance)
     &        write(iptty, 40) 'air pressure', pcidifmax, toldc
         if (balance_tol .ne. tolerance) write(iptty, 40)
     &        'flow balance (IN-OUT)', flow_rate, balance_tol
         if (tolde .ne. tolerance) write(iptty, 40)
     &        'enthalpy balance (IN-OUT)', enth_rate, tolde
         write(iptty,42) tmch
         if (isty .ne. 0) write(iptty,51)
      endif

 40   format ('>>>>> Max change in ', a, 1pg12.4, ' tolerance',
     &     1pg12.4, ' <<<<<')
 43   format ('>>>>> Gridblock Max Pres change ',i8,
     &     ' Pres(new) ',1p,g12.4,' Pres(old) ',g12.4,
     &      ' Zone ',i6,' <<<<<')
 44   format ('>>>>> Gridblock Max Sat change ',i8,
     &     ' Sat(new) ',1p,g12.4,' Sat(old) ',g12.4,
     &     ' Zone ',i6,' <<<<<')
  45  format ('>>>>> Gridblock Max Mass change ',i8,' Frac change ',1p,
     &       g12.4,' Total Mass change ',g14.6,' Zone ',i6,' <<<<<')
 41   format (/, '>>>>> Steady state check (', a, ') <<<<<')
 42   format ('>>>>> Equation tolerance (',1p,g12.4, ') <<<<<')
 51   format(/,'>>>>> Starting transient with steady solution <<<<<',/)

      end subroutine write_steady_state

      end subroutine steady


      SUBROUTINE COMPFG(XPARAM,INT,ESCF,FULSCF,GRAD,LGRAD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XPARAM(MAXPAR),GRAD(MAXPAR)
      LOGICAL LGRAD, FULSCF
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR),IDUMY,DUMY(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /ATHEAT/ ATHEAT
      COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC)
      COMMON /ENUCLR/ ENUCLR
      COMMON /NATYPE/ NZTYPE(107),MTYPE(30),LTYPE
      COMMON /ELECT / ELECT
      PARAMETER (MDUMY=MAXPAR**2-MPACK)
      COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MDUMY)
      COMMON /HMATRX/ H(MPACK)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM), NB(NUMATM), NC(NUMATM)
      COMMON /ERRFN  / ERRFN(MAXPAR), AICORR(MAXPAR)
      COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB)
      COMMON /LAST  / LAST
      COMMON /NUMCAL/ NUMCAL
      COMMON /SCFTYP/ EMIN, LIMSCF
      COMMON /MOLMEC/ HTYPE(4),NHCO(4,20),NNHCO,ITYPE
     1       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     2                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     3                NCLOSE,NOPEN,NDUMY,FRACT
C COSMO change A. Klamt
      LOGICAL ISEPS, USEPS , UPDA
      COMMON /ISEPS/  ISEPS, USEPS, UPDA
C end of COSMO change
C***********************************************************************
C
C   COMPFG CALCULATES (A) THE HEAT OF FORMATION OF THE SYSTEM, AND
C                     (B) THE GRADIENTS, IF LGRAD IS .TRUE.
C
C   ON INPUT  XPARAM = ARRAY OF PARAMETERS TO BE USED IN INTERNAL COORDS
C             LGRAD  = .TRUE. IF GRADIENTS ARE NEEDED, .FALSE. OTHERWISE
C             INT    = .TRUE. IF HEAT OF FORMATION IS TO BE CALCULATED
C             FULSCF = .TRUE. IF FULL SCF TO BE DONE, .FALSE. OTHERWISE.
C
C   ON OUTPUT ESCF  = HEAT OF FORMATION.
C             GRAD   = ARRAY OF GRADIENTS, IF LGRAD = .TRUE.
C
C***********************************************************************
      COMMON /KEYWRD/KEYWRD
      CHARACTER*241 KEYWRD
      LOGICAL DEBUG, INT, PRINT, ANALYT, LARGE, USEDCI,
     1FORCE, TIMES, AIDER
      DIMENSION COORD(3,NUMATM), W(N2ELEC), DEGREE(3), XPAREF(MAXPAR)
     1,DELTAP(NMECI**2) ,DELTA(NMECI*MAXORB)
      SAVE DEGREE, PRINT, DEBUG
      EQUIVALENCE (W,WJ)
      DATA ICALCN /0/
C                 MNDO     AM1      PM3      MINDO/
      IF (ICALCN.NE.NUMCAL) THEN
         ICALCN=NUMCAL
         HTYPE(1)=6.1737D0
         HTYPE(2)=3.3191D0
         HTYPE(3)=7.1853D0
         HTYPE(4)=1.7712D0
         LTYPE=0
         DO 30 I=1,NUMAT
            IF(NAT(I).LT.99)THEN
               DO 10 J=1,LTYPE
   10          IF(NAT(I).EQ.MTYPE(J)) GOTO 20
               LTYPE=LTYPE+1
               MTYPE(LTYPE)=NAT(I)
               NZTYPE(NAT(I))=LTYPE
C
C       LTYPE = NUMBER OF TYPES OF REAL ATOM PRESENT
C       MTYPE = TYPES OF REAL ATOMS PRESENT
               J=LTYPE
   20          CONTINUE
            ENDIF
   30    CONTINUE
         AIDER=(INDEX(KEYWRD,'AIDER').NE.0)
         TIMES=(INDEX(KEYWRD,'TIMES').NE.0)
         ANALYT=(INDEX(KEYWRD,'ANALYT').NE.0)
         IF(INT.AND.ANALYT)CALL SETUPG
         DEGREE(1)=1.D0
         IF(INDEX(KEYWRD,' XYZ').NE.0)THEN
            DEGREE(2)=1.D0
         ELSE
            DEGREE(2)=180.D0/3.141592652589D0
         ENDIF
         DEGREE(3)=DEGREE(2)
         USEDCI=(NCLOSE.NE.NOPEN.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0
     1         .OR.(INDEX(KEYWRD,'C.I.').NE.0))
         FORCE=(INDEX(KEYWRD,'FORCE').NE.0)
         LARGE=(INDEX(KEYWRD,'LARGE') .NE. 0)
         PRINT=(INDEX(KEYWRD,'COMPFG') .NE. 0)
         DEBUG=(INDEX(KEYWRD,'DEBUG') .NE. 0 .AND. PRINT)
         EMIN=0.D0
         DO 40 I=1,NVAR
   40    XPAREF(I)=XPARAM(I)
      ENDIF
C
C SET UP COORDINATES FOR CURRENT CALCULATION
C
C       PLACE THE NEW VALUES OF THE VARIABLES IN THE ARRAY GEO.
C       MAKE CHANGES IN THE GEOMETRY.
      DO 50 I=1,NVAR
         K=LOC(1,I)
         L=LOC(2,I)
   50 GEO(L,K)=XPARAM(I)
C      IMPOSE THE SYMMETRY CONDITIONS + COMPUTE THE DEPENDENT-PARAMETERS
      IF(NDEP.NE.0) CALL SYMTRY
C      NOW COMPUTE THE ATOMIC COORDINATES.
      IF( DEBUG ) THEN
         IF( LARGE ) THEN
            K=NATOMS
         ELSE
            K=MIN(5,NATOMS)
         ENDIF
         WRITE(6,FMT='('' INTERNAL COORDS'',/100(/,3F12.6))')
     1            ((GEO(J,I)*DEGREE(J),J=1,3),I=1,K)
      END IF
      CALL GMETRY(GEO,COORD)
      IF( DEBUG ) THEN
         IF( LARGE ) THEN
            K=NUMAT
         ELSE
            K=MIN(5,NUMAT)
         ENDIF
         WRITE(6,FMT='('' CARTESIAN COORDS'',/100(/,3F16.9))')
     1            ((COORD(J,I),J=1,3),I=1,K)
      ENDIF
      IF(INT.AND.ANALYT)REWIND 2
C COSMO change A. Klamt
      IF (.NOT. USEPS) THEN
C end of COSMO change
      IF(TIMES)CALL TIMER('BEFORE HCORE')
      IF(INT)CALL HCORE(COORD, H, W, WJ, WK, ENUCLR)
      IF(TIMES)CALL TIMER('AFTER HCORE')
C
C COMPUTE THE HEAT OF FORMATION.
C
      IF(NORBS.GT.0.AND.NELECS.GT.0) THEN
         IF(TIMES)CALL TIMER('BEFORE ITER')
         IF(INT) CALL ITER(H, W, WJ, WK, ELECT, FULSCF,.TRUE.)
         IF(TIMES)CALL TIMER('AFTER ITER')
      ELSE
         ELECT=0.D0
      ENDIF
      ESCF=(ELECT+ENUCLR)*23.061D0+ATHEAT
      IF(ESCF.LT.EMIN.OR.EMIN.EQ.0.D0)EMIN=ESCF
      DO 60 I=1,NNHCO
         CALL DIHED(COORD,NHCO(1,I),NHCO(2,I),NHCO(3,I),NHCO(4,I),ANGLE)
         ESCF=ESCF+HTYPE(ITYPE)*SIN(ANGLE)**2
   60 CONTINUE
C COSMO change A. Klamt 18.7.91
      ENDIF
      IF (ISEPS) THEN
C The following routine constructs the dielectric screening surface
           CALL CONSTS (COORD,.TRUE.)
C The following routine constructs dielectric response matrix CCMAT
        CALL BTOC (COORD)
C A. Klamt 18.7.91
        USEPS = .TRUE.
        IF(TIMES) CALL TIMER('BEFORE HCORE')
        IF(INT) CALL HCORE(COORD, H, W, WJ, WK, ENUCLR)
        IF(TIMES) CALL TIMER('AFTER HCORE')
C
C COMPUTE THE HEAT OF FORMATION.
C
        IF(NORBS.GT.0.AND.NELECS.GT.0) THEN
          IF(TIMES) CALL TIMER('BEFORE ITER')
          IF(INT) CALL ITER(H, W, WJ, WK, ELECT, FULSCF,.TRUE.)
          IF(TIMES) CALL TIMER('AFTER ITER')
        ELSE
          ELECT=0.D0
        ENDIF
        ESCF=(ELECT+ENUCLR)*23.060542301389D0+ATHEAT
        IF(ESCF.LT.EMIN.OR.EMIN.EQ.0.D0) EMIN=ESCF
        DO 61 I=1,NNHCO
         CALL DIHED(COORD,NHCO(1,I),NHCO(2,I),NHCO(3,I),NHCO(4,I),ANGLE)
         ESCF=ESCF+HTYPE(ITYPE)*SIN(ANGLE)**2
   61   CONTINUE
      ENDIF
C end of COSMO change
C
C FIND DERIVATIVES IF DESIRED
C
      IF(LGRAD) THEN
         IF(TIMES)CALL TIMER('BEFORE DERIV')
         CALL DERIV(GEO,GRAD)
         IF(TIMES)CALL TIMER('AFTER DERIV')
      ENDIF
      IF(AIDER)THEN
C
C  ADD IN AB INITIO CORRECTION
C
         DO 70 I=1,NVAR
   70    ESCF=ESCF+(XPARAM(I)-XPAREF(I))*AICORR(I)
      ENDIF
      IF(INT.AND.PRINT)
     1WRITE(6,'(/10X,'' HEAT OF FORMATION'',G30.17)')ESCF
      IF(PRINT.AND.LGRAD)
     1   WRITE(6,FMT='('' GRADIENT       '',8F8.2,(/10F8.2))')
     2                (GRAD(I),I=1,NVAR)
C
C REFORM DENSITY MATRIX, IF A C.I. DONE AND EITHER THE LAST SCF OR A
C FORCE CALCULATION
C
      IF(USEDCI.AND. (LAST.EQ.1 .OR. FORCE))
     1CALL MECIP(C,NORBS,DELTAP,DELTA)
      RETURN
      END