      SUBROUTINE RCONTR(
     &   NIN, NOUT, FCOORD, FRADIU, FHYDRA, FPDBSP, CPOINT,
     &   CVECT, SAMPLE, DOTDEN, MCSTEP, MCLEN, MCKTIN,
     &   LDOT, LSPIKE, LLINE, LCEN, LERR, LDBUG, FSEED, ENDRAD,
     &   LSPHBX, LCAPS, MOLQPT, SHORTO, IGNRES, FCHARM, CHSKIP,
     &   PEGRAT, F2DMAP, CUTSIZE, LRAT, CONNR, LEXTRA, PEG_WRITEALL)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1993 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1997 Oliver Smart                    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 12/93	O.S. Smart	Original public release in HOLE suite beta1.0
C 05/94 O.S. Smart      spherebox option flag read (LSPHBX) added
C 05/95 O.S. Smart	capsule option flag LCAPS read added
C 11/95 O.S. Smart	LINOFF card changed to LINON
C 11/95 O.S. Smart	s/r STRIPS used to strip initial blanks
C			new options: MOLQPT, SHORTO, IGNORE, CHARMD
C 01/96 O.S. Smart	new option PEGRAT added
C 02/96 O.S. Smart      new s/r dtilda added to resolve ~'s in filenames
C 12/97 O.S.S.		new vble CUTSIZE added
C 12/97 O.S.S.		RAT option introduced!?
C 01/00 O.S.S.    	CONN option introduced
C 10/00 O.S.S.    	FORPEG CARD introduced (to PEG_WRITEALL vble)

C this s/r read values for control vbles for program hole from input
C stream nin. Uses s/r freda to decode lines. N.b. no check is made
C on specification here - this is done in hole.
C conventions used in this s/r MUST be documented in hole.doc

C routine FREDA used here to decode lines include common vbles
C vbles used by freda
C col: 	c*80		the command?
C kl: 	int 		no of words inputed 0 then default
C fn:	r*4(40) 	no.'s as they occur
C kn:     int     	no. of no's
C fl:     c*1(40,6)	words?
      INCLUDE 'FREDAINC'

C input and output streams
C returned unchanged!
      INTEGER			NIN, NOUT

C input coordinate filename
      CHARACTER*200		FCOORD
C input radius filename
      CHARACTER*200		FRADIU
C hydra binary plot output file - default to none
      CHARACTER*200		FHYDRA
C pdb format file for sphere centre info
      CHARACTER*200		FPDBSP
C
C an initial point in the channel
      DOUBLE PRECISION		CPOINT(3)

C a vector in the direction of the channel
      DOUBLE PRECISION		CVECT(3)

C a sampling distance - the distance between planes
C default to 0.5 angs
      DOUBLE PRECISION		SAMPLE

C a dot density for dot surface
C same definition as in hydra - value between 5 and 30
C default to 15
      INTEGER			DOTDEN

C the no. of Monte Carlo steps
      INTEGER			MCSTEP

C max. length in angs of each Montecarlo displacement (angs),
C divison term in Monte Carlo probability (also angs)
C starting value and current value
      DOUBLE PRECISION		MCLEN, MCKTIN

C
C if are drawing graphical representation of results
C can turn off the dot surface by setting ldot false
C or turn off lines joining each sphere centre to
C the two closest atoms	by setting ldot false
      LOGICAL			LDOT, LLINE, LCEN

C if lspike is set true produce spikes from sphere surface
C rather than dots
      LOGICAL			LSPIKE

C if error found set LERR true
      LOGICAL			LERR

C if ldbug set true then mirror input
      LOGICAL			LDBUG

C 24 October 1993 - new feature allow user specify
C the seed integer for random number generator
      INTEGER			FSEED

C 22 Nov 1993 - allow user to specify radius above which
C result is regarded as an end
      DOUBLE PRECISION		ENDRAD

C 17 June 1994 - new flag (LSPHBX) to turn on ellipsoid option
      LOGICAL			LSPHBX

C 18/05/95 new option for a capsule
C turn on by setting LCAPS = true
      LOGICAL                   LCAPS

C 30/10/95 add facility to produce a .qpt of the molecule itself
C for non-quanta users
      CHARACTER*200             MOLQPT

C 11/95 introduce new variable to reduce text output -
C if shorto =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C 11/95 string listing residues not be read
      CHARACTER*80		IGNRES

C 11/95 input multiple positions from charmm .dcd molecular dynamics file
C filename,  Number of datasets to skip before initial read,
C number to skip between reads
      CHARACTER*200             FCHARM
      INTEGER                   CHSKIP(2)

C vbles for working peg effect on conductance -
C first number the ratio of conductance with PEG about to water
C second number is the ratio for non-penetrating PEG
      DOUBLE PRECISION          PEGRAT(2)

C filename root for h2dmap - if not set to NONE
C a number of files will be produced using this as basis
C appending map type and file identifier to end of this string
      CHARACTER*200             F2DMAP

C cut off list control vble, -ve: no cutoff lists used in calculation
C otherwise this is the additional radius above the sphere radius
C to be used for cutoff list (see s/r holeen)
      DOUBLE PRECISION		CUTSIZE

C option "rat" introduced 12/97 - this uses standard HOLE input but
C a completely different algorithm designed for finding escape routes from
C active sites.
      LOGICAL			LRAT

C option CONN introduced 1/00 -
C CONNR(1) is the connolly surface probe radius (default 1.15Angs)
C          the option is turned off by setting this radius negative
C CONNR(2) is the grid size to be used in the calculation - default .25 angs
      DOUBLE PRECISION		CONNR(2)

C extra key controls whether information as for
C Graph of surface properties vs coordinate along cvect
C and crude electrostatic potential
C produced by calls to HSURFP and HELEFI from HOGRAP
      LOGICAL			LEXTRA

C PEG_WRITEALL: extra key for new separate PEG calculation - program peg_calc
C turn on with FORPEG card in control file
C this vble is to be acted on in s/r CONCAL making it
C write all the spheres found to the .sph file without any editing
      LOGICAL			PEG_WRITEALL

C internal variables ***********

C the first word returned by freda
      CHARACTER*6		KEY

C dummy integer
      INTEGER			IDUM

C end of decs ******************

C mirror input lines
      WRITE( NOUT,  '(/1X,A)')
     & 'Control variables read:'

C read line do until EOF or STOP read and then return @55555
10    CONTINUE

	READ( NIN, '(A)', END= 55555) COL
	CALL CHREND( COL, IDUM)
	WRITE( NOUT,'(A)') COL(1:IDUM)

C remove any comment
	CALL DECOM( COL)

C if debugging mirror line back
	IF (LDBUG) WRITE( NOUT,  '(1X,A,A)')
     &	'debug dcom line: ', COL(1:IDUM)

C if line blank then read next
	IF (COL(1:5).EQ.'     ') GOTO 10

C decode line with freda
	CALL FREDA(1,80,FL,6)

C first word is key
C No word?
	IF (KL.EQ.0) GOTO 10
C fl:	  c*1(40,6)	words?
	KEY = FL(1,1)//FL(1,2)//FL(1,3)//FL(1,4)//FL(1,5)//FL(1,6)
C make upper case
	CALL UCASE( KEY)
	IF (LDBUG) WRITE( NOUT,  '(1X,A,A)')
     &		  'debug key: ', key

C key
	IF (KEY.EQ.'STOP') THEN
C stop input
	  GOTO 55555

C pdb input filename
	ELSEIF (KEY(1:5).EQ.'COORD') THEN
	  FCOORD = COL(6:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(FCOORD)
C resolve any tilda's (~) in filename
          CALL DTILDA(FCOORD)

C radius filename
	ELSEIF (KEY.EQ.'RADIUS') THEN
	  FRADIU = COL(7:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(FRADIU)
C resolve any tilda's (~) in filename
          CALL DTILDA(FRADIU)

C molqpt filename
        ELSEIF (KEY.EQ.'MOLQPT') THEN
          MOLQPT = COL(7:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(MOLQPT)
C resolve any tilda's (~) in filename
          CALL DTILDA(MOLQPT)

C binary plot filename - output
	ELSEIF (KEY.EQ.'PLTOUT') THEN
	  FHYDRA = COL(7:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(FHYDRA)
C resolve any tilda's (~) in filename
          CALL DTILDA(FHYDRA)

C pdb file for sphere info - output
	ELSEIF (KEY.EQ.'SPHPDB') THEN
	  FPDBSP = COL(7:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(FPDBSP)
C resolve any tilda's (~) in filename
          CALL DTILDA(FPDBSP)

C 2d property output filename root
	ELSEIF (KEY.EQ.'2DMAPS') THEN
	  F2DMAP = COL(7:80)
          CALL STRIPS(F2DMAP)
C resolve any tilda's (~) in filename
          CALL DTILDA(F2DMAP)

C charm dcd file
        ELSEIF (KEY.EQ.'CHARMD') THEN
          FCHARM = COL(7:80)
C strips strips off any leading blanks or tabs from the filename
          CALL STRIPS(FCHARM)
C resolve any tilda's (~) in filename
          CALL DTILDA(FCHARM)

C number of positions to skip on charmm read
        ELSEIF (KEY.EQ.'CHARMS') THEN
          IF (KN.LT.2) THEN
            LERR = .TRUE.
            WRITE( NOUT,'(/20(1X,A:))')
     &'ERROR: CHARMS (number of positions to skip on .dcd read)',
     &'must be specified with two numbers ',
     &'(the initial skip & number to skip between reads',
     &  'line read:', COL
          ENDIF
          CHSKIP(1) = FN(1)
          CHSKIP(2) = FN(2)

C peg graph ratios
        ELSEIF (KEY.EQ.'PEGRAT') THEN
          IF (KN.LT.2) THEN
            LERR = .TRUE.
            WRITE( NOUT,'(A)')
     &' ',
     &' ERROR: PEGRAT (ratio of conductances in presence and ',
     &'                with non-penetrating PEGs)',
     &' must be specified with two numbers ',
     &' line read: '//COL
          ENDIF
          PEGRAT(1) = FN(1)
          PEGRAT(2) = FN(2)

C turn dot surface off?
	ELSEIF (KEY.EQ.'DOTOFF') THEN
	  LDOT = .FALSE.
C spikes rather than dots?
	ELSEIF (KEY.EQ.'SPIKES') THEN
          LSPIKE = .TRUE.
C turn drawing of lines off?
C in old days used LINOFF card - now do LINON
	ELSEIF (KEY.EQ.'LINOFF') THEN
	  CONTINUE
	ELSEIF (KEY.EQ.'LINON ') THEN
	  LLINE = .TRUE.
C turn drawing of centre line off?
	ELSEIF (KEY.EQ.'CENOFF') THEN
	  LCEN = .FALSE.
C dot density
	ELSEIF (KEY.EQ.'DOTDEN') THEN
	  IF (KN.LT.1) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: DOTDEN (the dot density for surface)',
     &	'must be specified with a number!',
     &	'line read:', COL
	  ENDIF
	  DOTDEN = INT(FN(1))

C Monte Carlo step
	ELSEIF (KEY.EQ.'MCSTEP') THEN
	  IF (KN.LT.1) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: MCSTEP (the no of Monte Carlo steps)',
     &	'must be specified with a number!',
     &	'line read:', COL
	  ENDIF
	  MCSTEP = INT(FN(1))

C Monte Carlo maximum displacement
	ELSEIF (KEY.EQ.'MCDISP') THEN
	  IF (KN.LT.1) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: MCDISP (the max Monte Carlo displacement)',
     &	'must be specified with a number!',
     &	'line read:', COL
	  ENDIF
	  MCLEN = FN(1)

C Monte Carlo initial KT
	ELSEIF (KEY.EQ.'MCKT') THEN
	  IF (KN.LT.1) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: MCKT (the initial Monte Carlo KT)',
     &	'must be specified with a number!',
     &	'line read:', COL
	  ENDIF
	  MCKTIN = FN(1)

C sampling distance
	ELSEIF (KEY.EQ.'SAMPLE') THEN
	  IF (KN.LT.1) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: SAMPLE (the distance between planes)',
     &	'must be specified with a number!',
     &	'line read:', COL
	  ENDIF
	  SAMPLE = FN(1)

C seed for random number generator
        ELSEIF (KEY.EQ.'RASEED') THEN
          IF (KN.LT.1) THEN
            LERR = .TRUE.
            WRITE( NOUT,'(/20(1X,A:))')
     &  'ERROR: RASEED (seed number for random # gen)',
     &  'must be specified with a number!',
     &  'line read:', COL
          ENDIF
C get problem using freda - use read instead
          READ( COL(8:18),'(BN,I10)') FSEED

C radius for end
        ELSEIF (KEY.EQ.'ENDRAD') THEN
          IF (KN.LT.1) THEN
            LERR = .TRUE.
            WRITE( NOUT,'(/20(1X,A:))')
     &  'ERROR: ENDRAD (radius for end)',
     &  'must be specified with a number!',
     &  'line read:', COL
          ENDIF
          ENDRAD = FN(1)

C channel direction vector
	ELSEIF (KEY.EQ.'CVECT ') THEN
	  IF (KN.LT.3) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: CVECT (the channel direction vector)',
     &	'must be specified with three no.''s',
     &	'line read:', COL
	  ENDIF
C the vector
	  CVECT(1) = FN(1)
	  CVECT(2) = FN(2)
	  CVECT(3) = FN(3)
C point in channel
	ELSEIF (KEY.EQ.'CPOINT') THEN
	  IF (KN.LT.3) THEN
	    LERR = .TRUE.
	    WRITE( NOUT,'(/20(1X,A:))')
     &	'ERROR: CPOINT (a point in the channel)',
     &	'must be specified with three no.''s',
     &	'line read:', COL
	  ENDIF
C the vector
	  CPOINT(1) = FN(1)
	  CPOINT(2) = FN(2)
	  CPOINT(3) = FN(3)

C turn on boxsphere option
        ELSEIF (KEY.EQ.'SPHBOX') THEN
          LSPHBX = .TRUE.

C turn on capsule option
        ELSEIF (KEY.EQ.'CAPSUL') THEN
          LCAPS  = .TRUE.

C turn on short output option
        ELSEIF (KEY.EQ.'SHORTO') THEN
C if no integer value specified then default to 1
          SHORTO  = 1
          IF (KN.GE.1) SHORTO = FN(1)

C residue types to be ignore
        ELSEIF (KEY.EQ.'IGNORE') THEN
	  IGNRES = COL(7:80)
C should be upper case
          CALL UCASE(IGNRES)
C strip off leading blanks
          CALL STRIPS(IGNRES)

C cut off list control vble
        ELSEIF (KEY(1:3).EQ.'CUT') THEN
          IF (KN.LT.1) THEN
            LERR = .TRUE.
            WRITE( NOUT,'(/20(1X,A:))')
     &  'ERROR: CUTSIZE (cut off list control vble)',
     &  'must be specified with a number!',
     &  'line read:', COL
          ENDIF
          CUTSIZE = FN(1)

C turn on the rat option?
	ELSEIF (KEY(1:3).EQ.'RAT') THEN
	  LRAT = .TRUE.

C turn on the conn  option?
	ELSEIF (KEY(1:4).EQ.'CONN') THEN
C default radius  set in as -ve CONNR(1)
        CONNR(1) = -CONNR(1)
C first number if present is the probe radius, 2nd grid size
	  IF (KN.GE.1) CONNR(1) = FN(1)
C default grid size 0.7* connr(1)
          CONNR(2) = 0.7*CONNR(1)
	  IF (KN.GE.2) CONNR(2) = FN(2)

C turn on the extra information option?
	ELSEIF (KEY(1:5).EQ.'EXTRA') THEN
	  LEXTRA = .TRUE.

C PEG_WRITEALL: extra key for new separate PEG calculation - program peg_calc
C turn on with FORPEG card in control file
C this vble is to be acted on in s/r CONCAL making it
C write all the spheres found to the .sph file without any editing
	ELSEIF (KEY(1:6).EQ.'FORPEG') THEN
	  PEG_WRITEALL = .TRUE.

	ELSE
C unregonized line - tell user
	  WRITE( NOUT, '(1X,A,A)')
     &		  '***Unrecognized line read: ', COL
	ENDIF

C read next line
      GOTO 10

55555 RETURN
      END


	SUBROUTINE MT_WIND ( strwnd, idecd, iret )
C************************************************************************
C* MT_WIND                                                              *
C*                                                                      *
C* This subroutine will decode the wind direction, speed, and gust     	*
C* speed from a METAR wind field.  The values are stored in common.	*
C* Wind speeds are stored in the units in which they are reported.      *
C* 								        *
C* MT_WIND ( STRWND, IDECD, IRET )                    		        *
C*								        *
C* Input parameters: 						        *
C*      STRWND		CHAR*		Wind field			*
C*								        *
C* Output parameters:						        *
C*      RIVALS(IRDRCT)  REAL		Wind direction                  *
C*      RIVALS(IRSKNT)  REAL		Wind speed (kts)                *
C*      RIVALS(IRSPED)  REAL		Wind speed (m/sec)              *
C*      RIVALS(IRGUST)  REAL		Gust wind speed (kts)           *
C*      RIVALS(IRGUMS)  REAL		Gust wind speed (m/sec)         *
C*	IDECD		INTEGER		Decode decision flag            *
C*					  1 = field decoded	        *
C*					  0 = field not decoded     	*
C*	IRET		INTEGER		Return code                     *
C*	      		    		  0 = normal return		*
C*	                                  2 = units in wrong position	*
C*					  3 = presumed in KTS		*
C*					  4 = wind direction miscoding	*
C*					  5 = wind speed miscoding	*
C*					  6 = excessive variable wind	*
C*					  7 = wind gust miscoding	*
C*                                       -1 = no wind field found	*
C**								        *
C* Log:									*
C* D. Kidwell/NCEP 	 4/95                                           *
C* D. Kidwell/NCEP 	11/96   Changed variable wdir flag value to 0   *
C* K. Tyle/GSC		 1/97	Changed var. wind dir. value to IMISSD;	*
C*				additional check for miscoded wdir;	*
C*				change call to DC_WLOG; reorganize	*
C*				header and comments			*
C* K. Tyle/GSC		 2/97	Changed error processing; set limit	*
C*				on minimum string length		*
C* K. Tyle/GSC		 2/97	Handle miscoded units of 'KZ'		*
C* K. Tyle/GSC		 4/97	Check last index of substring >= first	*
C* D. Kidwell/NCEP 	 6/97   Replaced ST_LSTR with INDEX             *
C* D. Kidwell/NCEP 	 4/98   New interface; cleaned up; added KMH;   *
C*				use -99 to flag VRB wdir                *
C* D. Kidwell/NCEP 	 7/02   Fixed bug for gusts reported in KMH     *
C* D. Kidwell/NCEP 	 9/02   Moved most of code to BR_WIND           *
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
	INCLUDE 	'mtcmn.cmn'
C*
	CHARACTER*(*) 	strwnd
C*
	INCLUDE 	'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret  = -1
	idecd = 0
C
C*	Exit immediately if string is too small.
C
	IF ( INDEX ( strwnd, ' ' ) .le. 5 ) THEN
	    RETURN
	END IF
C
	CALL BR_WIND ( strwnd, drct, sknt, sped, gust, gums, idecd,
     +		       iret )
	IF ( .not. ERMISS ( drct ) ) rivals ( irdrct ) = drct
	IF ( .not. ERMISS ( sknt ) ) rivals ( irsknt ) = sknt
	IF ( .not. ERMISS ( sped ) ) rivals ( irsped ) = sped
	IF ( .not. ERMISS ( gust ) ) rivals ( irgust ) = gust
	IF ( .not. ERMISS ( gums ) ) rivals ( irgums ) = gums
C*
	RETURN
	END


      subroutine tedrawf(lfno,bc,bs,hc,hs,
     $     sige,anuz,mphi2,ndp)
      implicit none
      integer*4 mphi2,ndp,lfno,lene
      real*8 bc(10,mphi2,ndp),bs(10,mphi2,ndp),
     $     hc(4,mphi2,ndp),hs(4,mphi2,ndp),
     $     sige,anuz
      character*32 buf,autofg
      write(lfno,'(a,i5,a)')'mphi2=',mphi2,';',
     $     'ndp=',ndp,';'
      buf=autofg(sige,'12.9')
      call mathexp(buf)
      write(lfno,'(a)')'sige='//buf(1:lene(buf))//';'
      buf=autofg(anuz,'12.9')
      call mathexp(buf)
      write(lfno,'(a)')'nuz='//buf(1:lene(buf))//';'
      call matharray(bc,10,mphi2,ndp,mphi2,'bc=',lfno)
      call matharray(bs,10,mphi2,ndp,mphi2,'bs=',lfno)
      call matharray(hc,4,mphi2,ndp,mphi2,'hc=',lfno)
      call matharray(hs,4,mphi2,ndp,mphi2,'hs=',lfno)
      return
      end

      subroutine matharray(bc,n,mphi,ndp,mphi2,s,lfno)
      implicit none
      integer*4 n,mphi2,mphi,ndp,lfno,lene,l
      real*8 bc(n,mphi,ndp)
      integer*4 i,m,j
      character*(*) s
      character*64 s1
      l=lene(s)
      s1=s(:l)
      write(lfno,'(a)')s1(:l)//'{{'
      do j=1,ndp
        do m=1,mphi2
          call mathinit('{')
          do i=1,n
            call mathput(lfno,bc(i,m,j))
          enddo
          if(m .eq. mphi2)then
            call mathterm(lfno,'}')
          else
            call mathterm(lfno,'},')
          endif
        enddo
        if(j .eq. ndp)then
          write(lfno,'(a)')'}};'
        else
          write(lfno,'(a)')'},{'
        endif
      enddo
      return
      end

      subroutine mathinit(s)
      implicit none
      integer*4 lfno,ip,lene
      character*80 mb
      character*(*) s
      common /math/ip,mb
      ip=lene(s)+1
      mb=s(1:ip-1)
      return
      end

      subroutine mathterm(lfno,s)
      implicit none
      character*(*) s
      integer*4 lfno,ip,lene,l
      character*80 mb
      common /math/ip,mb
      l=lene(s)
      if(ip+l .gt. 81)then
        write(lfno,'(a)')mb(1:ip-1)
        ip=1
      endif
      mb(ip:80)=s(1:l)
      write(lfno,'(a)')mb(1:ip+l-1)
      return
      end

      subroutine mathput(lfno,a)
      implicit none
      character*32 buf,autofg
      real*8 a
      integer*4 lfno,ip,l,lene
      character*80 mb
      common /math/ip,mb
      buf=autofg(a,'S12.9')
      call mathexp(buf)
      l=lene(buf)
      if(ip .eq. 1)then
        mb=buf(1:l)
        ip=l+1
      elseif(mb(ip-1:ip-1) .eq. '{')then
        mb(ip:ip+l-1)=buf(1:l)
        ip=ip+l
      elseif(ip+l .lt. 80)then
        mb(ip:ip+l)=','//buf(1:l)
        ip=ip+l+1
      else
        mb(ip:ip)=','
        write(lfno,'(a)')mb(1:ip)
        mb=buf(1:l)
        ip=l+1
      endif
      return
      end

      subroutine mathexp(buf)
      implicit none
      character*(*) buf
      character*256 buf1
      integer*4 lene,i,j
      buf1=buf
      buf=' '
      j=1
      do i=1,lene(buf1)
        if(buf1(i:i) .eq. 'E')then
          buf(j:j+3)=' 10^'
          j=j+4
        else
          buf(j:j)=buf1(i:i)
          j=j+1
        endif
      enddo
      return
      end


module varslice

    use ncio
    use nml

    implicit none

    ! Internal constants
    integer,  parameter :: dp  = kind(1.d0)
    integer,  parameter :: sp  = kind(1.0)

    ! Choose the working precision of the library (sp,dp)
    integer,  parameter :: wp = sp

    ! Define default missing value
    real(wp), parameter :: mv = -9999.0_wp

    type varslice_param_class

        character(len=1024) :: filename
        character(len=56)   :: name
        character(len=56)   :: units_in
        character(len=56)   :: units_out
        real(wp) :: unit_scale
        real(wp) :: unit_offset
        logical  :: with_time

        ! Internal parameters
        integer, allocatable :: dim(:)
        integer  :: ndim
        real(wp) :: time_par(3)

    end type

    type varslice_class

        type(varslice_param_class) :: par

        ! Parameters defined during update call
        real(wp)          :: time_range(2)
        character(len=56) :: slice_method
        integer           :: range_rep

        ! Variable information
        real(wp), allocatable :: x(:)
        real(wp), allocatable :: y(:)
        real(wp), allocatable :: lev(:)

        real(wp), allocatable :: time(:)
        real(wp), allocatable :: var(:,:,:,:)
    end type

    private
    public :: varslice_class
    public :: varslice_update
    public :: varslice_init_nml
    public :: varslice_init_arg
    public :: varslice_end

contains

    subroutine varslice_update(vs,time,method,rep)
        ! Routine to update transient climate forcing to match
        ! current `time`.

        implicit none

        type(varslice_class),       intent(INOUT) :: vs
        real(wp),         optional, intent(IN)    :: time(:)    ! [yr] Current time, or time range
        character(len=*), optional, intent(IN)    :: method     ! slice_method (only if with_time==True)
        integer,          optional, intent(IN)    :: rep        ! Only if with_time==True, and slice_method==range_*

        ! Local variables
        integer :: k, k0, k1, nt, nt_now, nt_out
        integer :: n1, n2, i, j, l
        type(varslice_param_class) :: par
        logical  :: with_time
        real(wp) :: time_range(2)
        real(wp) :: time_wt(2)
        character(len=56) :: slice_method
        character(len=56) :: vec_method
        integer  :: range_rep
        integer,  allocatable :: kk(:)
        real(wp), allocatable :: var(:,:,:,:)

        ! Define shortcuts
        par = vs%par
        with_time = par%with_time

        if (with_time) then

            if (.not. present(time)) then
                write(*,*) "varslice_update:: Error: current time or time range &
                            &must be given as an argument (1D array)."
                stop
            end if

            ! Consistency check
            if (size(time,1) .eq. 2) then
                if (time(2) .lt. time(1)) then
                    write(*,*) "varslice_update:: Error: time(2) should be >= time(1)."
                    write(*,*) "time = ", time
                    stop
                end if
            end if

        end if

        slice_method = "exact"
        if (present(method)) slice_method = trim(method)

        range_rep = 1
        if (present(rep)) range_rep = rep

        if (present(time)) then

            if (size(time) .eq. 2) then
                time_range = time
            else
                time_range(1:2) = time(1)
            end if

        else

            time_range = vs%time_range

        end if

        if ( with_time .and. trim(slice_method) .eq. trim(vs%slice_method) &
                .and. range_rep .eq. vs%range_rep &
                .and. vs%time_range(1) .eq. time_range(1) &
                .and. vs%time_range(2) .eq. time_range(2) ) then

            ! Do nothing, the varslice object is already up to date
            ! fo the current time and method.

        else

            ! Set parameters in varslice object
            vs%slice_method = trim(slice_method)
            vs%range_rep    = range_rep
            vs%time_range   = time_range

            ! 2. Read variable and convert units as needed

            if (.not. with_time) then
                ! Handle cases that do not have time dimension (simpler)

                select case(par%ndim)

                    case(1)

                        ! 1D variable
                        call nc_read(par%filename,par%name,vs%var(:,1,1,1),missing_value=mv)

                    case(2)

                        ! 2D variable
                        call nc_read(par%filename,par%name,vs%var(:,:,1,1),missing_value=mv)

                    case(3)

                        ! 3D variable
                        call nc_read(par%filename,par%name,vs%var(:,:,:,1),missing_value=mv)

                    case DEFAULT

                        write(*,*) "varslice_update:: ndim >= 4 with no time dimension is not allowed."
                        write(*,*) "ndim = ", par%ndim
                        stop

                end select

            else
                ! Cases with a time dimension (more complicated)

                if (trim(slice_method) .eq. "interp" .or. &
                    trim(slice_method) .eq. "extrap") then
                    ! Update time range for interp/extrap methods

                    ! Time range should cover all available data since
                    ! bracketing indices to the desired time will be found
                    vs%time_range(1) = minval(vs%time)
                    vs%time_range(2) = maxval(vs%time)

                    ! Additional consistency check
                    if (size(time,1) .ne. 1) then
                        write(*,*) "varslice_update:: Error: to use slice_method=['interp','extrap'], &
                        &only one time should be provided as an argument."
                        write(*,*) "time = ", time
                        stop
                    end if

                end if

                ! Determine indices of data to load

                call get_indices(k0,k1,vs%time,vs%time_range,trim(slice_method),time(1))

                if (k0 .gt. 0 .and. k1 .gt. 0) then
                    ! Dimension range is available for loading, proceed

                    ! Get size of time dimension needed for loading
                    nt_now = k1-k0+1

                    ! write(*,*) "time: ", vs%time_range, k0, k1
                    ! write(*,*) "      ", vs%time(k0), vs%time(k1)

                    if (allocated(var)) deallocate(var)

                    select case(par%ndim)

                        case(1)

                            ! Allocate local var to the right size
                            allocate(var(nt_now,1,1,1))

                            ! 0D (point) variable plus time dimension
                            call nc_read(par%filename,par%name,var,missing_value=mv, &
                                    start=[k0],count=[nt_now])

                        case(2)

                            ! Allocate local var to the right size
                            allocate(var(par%dim(1),nt_now,1,1))

                            ! 1D variable plus time dimension
                            call nc_read(par%filename,par%name,var,missing_value=mv, &
                                    start=[1,k0],count=[par%dim(1),nt_now])

                        case(3)

                            ! Allocate local var to the right size
                            allocate(var(par%dim(1),par%dim(2),nt_now,1))

                            ! 2D variable plus time dimension
                            call nc_read(par%filename,par%name,var,missing_value=mv, &
                                    start=[1,1,k0],count=[par%dim(1),par%dim(2),nt_now])

                        case(4)

                            ! Allocate local var to the right size
                            allocate(var(par%dim(1),par%dim(2),par%dim(3),nt_now))

                            ! 3D variable plus time dimension
                            call nc_read(par%filename,par%name,var,missing_value=mv, &
                                    start=[1,1,1,k0],count=[par%dim(1),par%dim(2),par%dim(3),nt_now])

                        case DEFAULT

                            write(*,*) "varslice_update:: ndim > 4 with time dimension not allowed."
                            write(*,*) "ndim = ", par%ndim
                            stop

                    end select

                    ! At this point, the local var variable has been defined
                    ! with data from the file for the appropriate time indices

                    ! Next, we need to allocate the vs%var variable to the
                    ! appropriate size and perform any calculations on the time
                    ! indices of the local var variable as needed.

                    ! Handle special case: if only one time is available
                    ! for interp/extrap methods, then change method
                    ! to exact
                    if ( (trim(vs%slice_method) .eq. "interp" .or. &
                          trim(vs%slice_method) .eq. "extrap") .and. &
                          vs%time(k0) .eq. vs%time(k1)) then
                        ! Same time is given for upper and lower bound

                        slice_method = "exact"
                    end if

                    ! Now, allocate the vs%var variable to the right size

                    select case(trim(slice_method))

                        case("exact","range")
                            ! Allocate vs%var to the same size as var
                            ! and store all values

                            if (size(vs%var,1) .eq. size(var,1) .and. &
                                size(vs%var,2) .eq. size(var,2) .and. &
                                size(vs%var,3) .eq. size(var,3) .and. &
                                size(vs%var,4) .eq. size(var,4) ) then

                                ! No allocation needed size is the same

                            else

                                deallocate(vs%var)
                                allocate(vs%var(size(vs%var,1),size(vs%var,2),size(vs%var,3),size(vs%var,4)))

                            end if

                            ! Store data in vs%var
                            vs%var = var

                        case("interp","extrap")
                            ! var should have two time dimensions to interpolate
                            ! between. Allocate vs%var to appropriate size and
                            ! perform interpolation

                            if (nt_now .ne. 2) then
                                write(*,*) "varslice_update:: Error: something went wrong during &
                                &interpolation. More than 2 time slices are available to interpolate &
                                &between. Check!"
                                write(*,*) "nt_now = ", nt_now
                                write(*,*) "time   = ", time
                                write(*,*) "indices k0, k1: ", k0, k1
                                write(*,*) "times : ", vs%time(k0:k1)
                                stop
                            end if

                            ! Calculate time weighting between two extremes
                            time_wt(2) = (time(1)-vs%time(k0)) / (vs%time(k1) - vs%time(k0))
                            time_wt(1) = 1.0_wp - time_wt(2)

                            if (minval(time_wt) .lt. 0.0_wp .or. maxval(time_wt) .gt. 1.0_wp) then
                                write(*,*) "varslice_update:: Error: interpolation weights are incorrect."
                                write(*,*) "time_wt  = ", time_wt
                                write(*,*) "time     = ", time
                                write(*,*) "time(k0) = ", vs%time(k0)
                                write(*,*) "time(k1) = ", vs%time(k1)
                                stop
                            end if

                            ! Note: slice_method='interp' and 'extrap' use the same method, since
                            ! the indices determine interpolation weights (ie,
                            ! for slice_method='interp', if the time of interest lies
                            ! outside of the bounds of the data, then k0=k1=-1 and
                            ! output data are set to missing values)

                            vec_method = "mean"     ! interp methods use the (weighted) mean
                            nt_out     = 1          ! We expect one time out

                            deallocate(vs%var)

                            select case(par%ndim)

                                case(1)
                                    allocate(vs%var(nt_out,1,1,1))

                                    ! Calculate the vector value desired (wtd mean)
                                    call calc_vec_value(vs%var(1,1,1,1),var([1,2],1,1,1),vec_method,mv,wt=time_wt)

                                case(2)
                                    allocate(vs%var(size(var,1),nt_out,1,1))

                                    do i = 1, size(vs%var,1)
                                        ! Calculate the vector value desired (mean,sd,...)
                                        call calc_vec_value(vs%var(i,1,1,1),var(i,[1,2],1,1),vec_method,mv,wt=time_wt)
                                    end do

                                case(3)
                                    allocate(vs%var(size(var,1),size(var,2),nt_out,1))

                                    do j = 1, size(vs%var,2)
                                    do i = 1, size(vs%var,1)
                                        ! Calculate the vector value desired (mean,sd,...)
                                        call calc_vec_value(vs%var(i,j,1,1),var(i,j,[1,2],1),vec_method,mv,wt=time_wt)
                                    end do
                                    end do

                                case(4)
                                    allocate(vs%var(size(var,1),size(var,2),size(var,3),nt_out))

                                    do l = 1, size(vs%var,3)
                                    do j = 1, size(vs%var,2)
                                    do i = 1, size(vs%var,1)
                                        ! Calculate the vector value desired (mean,sd,...)
                                        call calc_vec_value(vs%var(i,j,l,1),var(i,j,l,[1,2]),vec_method,mv,wt=time_wt)
                                    end do
                                    end do
                                    end do

                            end select

                        case("range_mean","range_sd","range_min","range_max","range_sum")
                            ! Allocate vs%var to match desired output size,
                            ! and calculate output values

                            ! Define 'vec_method'
                            n1 = index(slice_method,"_")
                            n2 = len_trim(slice_method)
                            vec_method = slice_method(n1+1:n2)

                            ! Size of dimension out is the size of the
                            ! repitition desired. Ie, range_rep = 1 means
                            ! to apply mean/sd/etc to all values along dimension
                            ! with the result of calculating 1 value.
                            ! range_rep = 12 means apply calculation to every 12th
                            ! value, resulting in 12 values along dimension.

                            nt_out = vs%range_rep

                            ! Make sure that var has at least as many values as we expect
                            if (nt_out .gt. nt_now) then
                                write(*,*) "varslice_update:: Error: the specified time range &
                                    & does not provide enough data points to be consistent with &
                                    & the specified value of range_rep."
                                write(*,*) "time_range      = ", vs%time_range
                                write(*,*) "nt (time_range) = ", nt_now
                                write(*,*) "range_rep       = ", vs%range_rep
                                write(*,*) "range_rep must be <= nt."
                                stop
                            end if

                            deallocate(vs%var)

                            select case(par%ndim)

                                case(1)
                                    allocate(vs%var(nt_out,1,1,1))

                                    ! Calculate each slice
                                    do k = 1, nt_out

                                        ! Get indices for current repitition
                                        call get_rep_indices(kk,i0=k,i1=nt_now,nrep=vs%range_rep)

                                        ! Calculate the vector value desired (mean,sd,...)
                                        call calc_vec_value(vs%var(k,1,1,1),var(kk,1,1,1),vec_method,mv)

                                    end do

                                case(2)
                                    allocate(vs%var(size(var,1),nt_out,1,1))

                                    ! Calculate each slice
                                    do k = 1, nt_out

                                        ! Get indices for current repitition
                                        call get_rep_indices(kk,i0=k,i1=nt_now,nrep=vs%range_rep)

                                        do i = 1, size(vs%var,1)
                                            ! Calculate the vector value desired (mean,sd,...)
                                            call calc_vec_value(vs%var(i,k,1,1),var(i,kk,1,1),vec_method,mv)
                                        end do

                                    end do

                                case(3)
                                    allocate(vs%var(size(var,1),size(var,2),nt_out,1))

                                    ! Calculate each slice
                                    do k = 1, nt_out

                                        ! Get indices for current repitition
                                        call get_rep_indices(kk,i0=k,i1=nt_now,nrep=vs%range_rep)

                                        do j = 1, size(vs%var,2)
                                        do i = 1, size(vs%var,1)
                                            ! Calculate the vector value desired (mean,sd,...)
                                            call calc_vec_value(vs%var(i,j,k,1),var(i,j,kk,1),vec_method,mv)
                                        end do
                                        end do

                                    end do

                                case(4)
                                    allocate(vs%var(size(var,1),size(var,2),size(var,3),nt_out))

                                    ! Calculate each slice
                                    do k = 1, nt_out

                                        ! Get indices for current repitition
                                        call get_rep_indices(kk,i0=k,i1=nt_now,nrep=vs%range_rep)

                                        do l = 1, size(vs%var,3)
                                        do j = 1, size(vs%var,2)
                                        do i = 1, size(vs%var,1)
                                            ! Calculate the vector value desired (mean,sd,...)
                                            call calc_vec_value(vs%var(i,j,l,k),var(i,j,l,kk),vec_method,mv)
                                        end do
                                        end do
                                        end do

                                    end do

                            end select

                    end select

                else
                    ! Dimension range was not found, set variable to missing values

                    vs%var = mv

                end if

            end if

            ! Make sure crazy values have been set to missing (for safety)
            where (abs(vs%var) .ge. 1e10) vs%var = mv

            ! Apply scaling
            where (vs%var .ne. mv)
                vs%var = vs%var*par%unit_scale + par%unit_offset
            end where

        end if

        return

    end subroutine varslice_update

    subroutine get_indices(k0,k1,x,xrange,slice_method,x_interp)
        ! Get the indices k0 and k1 that
        ! correspond to the lower and upper bound
        ! range of xmin <= x <= xmax.

        ! Resulting indices should either match
        ! the range exactly, or bracket the range of interest

        ! Note: routine assumes xmin <= xmax!

        implicit none

        integer,  intent(OUT) :: k0
        integer,  intent(OUT) :: k1
        real(wp), intent(IN)  :: x(:)
        real(wp), intent(IN)  :: xrange(2)
        character(len=*), intent(IN) :: slice_method
        real(wp), intent(IN)  :: x_interp               ! only used for interp methods

        ! Local variables
        integer  :: k, nk
        real(wp) :: xmin, xmax

        xmin = xrange(1)
        xmax = xrange(2)

        nk = size(x,1)

        ! Get lower bound
        k0 = 1
        do k = 1, nk
            if (x(k) .gt. xmin) exit
            k0 = k
        end do

        if (xmax .eq. xmin) then

            k1 = k0

        else

            ! Get upper bound
            k1 = nk
            do k = nk, k0, -1
                if (x(k) .lt. xmax) exit
                k1 = k
            end do

        end if

        ! Make sure indices work for slice_method of choice
        select case(trim(slice_method))

            case("exact")

                ! If index wasn't found, set idices to -1
                if (x(k0) .ne. xmin) then
                    k0 = -1
                    k1 = -1
                end if

            case("interp")

                ! If xmin/xmax are not found in range, set indices to -1
                if (x_interp .gt. xmax .or. x_interp .lt. xmin) then
                    k0 = -1
                    k1 = -1

                else

                    ! Redo indices to get nearest bracketing points in time_range

                    ! Get lower bound
                    k0 = 1
                    do k = 1, nk
                        if (x(k) .gt. x_interp) exit
                        k0 = k
                    end do

                    ! Get upper bound
                    k1 = nk
                    do k = nk, k0, -1
                        if (x(k) .lt. x_interp) exit
                        k1 = k
                    end do

                end if

            case("extrap")

                ! If xmin/xmax are not found in range,
                ! set indices to extreme bound
                if (minval(x) .gt. x_interp) then

                    k0 = 1
                    k1 = 1

                else if (maxval(x) .lt. x_interp) then

                    k0 = nk
                    k1 = nk

                else

                    ! Redo indices to get nearest bracketing points in time_range

                    ! Get lower bound
                    k0 = 1
                    do k = 1, nk
                        if (x(k) .gt. x_interp) exit
                        k0 = k
                    end do

                    ! Get upper bound
                    k1 = nk
                    do k = nk, k0, -1
                        if (x(k) .lt. x_interp) exit
                        k1 = k
                    end do

                end if

            case("range","range_mean","range_sd","range_min","range_max")

                ! If xmin/xmax are not found in range, set indices to -1
                if (minval(x) .gt. xmax .or. maxval(x) .lt. xmin) then
                    k0 = -1
                    k1 = -1
                end if

            ! No default case
        end select

        return

    end subroutine get_indices

    subroutine get_rep_indices(ii,i0,i1,nrep)
        ! Given starting value i0 and final value i1,
        ! and number of values to skip nrep, generate
        ! an vector of indices ii.
        ! eg, i0 = 1, i1 = 36, nrep = 12
        ! => ii = [1,13,25]
        ! eg, i0 = 2, i1 = 36, nrep = 12
        ! => ii = [2,14,26]

        implicit none

        integer, allocatable, intent(OUT) :: ii(:)
        integer, intent(IN) :: i0
        integer, intent(IN) :: i1
        integer, intent(IN) :: nrep

        ! Local variables
        integer :: i, ni, ntot
        integer :: jj(10000)

        ni = i1-i0+1

        jj = 0

        do i = 1, ni
            jj(i) = i0 + nrep*(i-1)
            if (jj(i) .gt. i1) then
                jj(i) = 0
                exit
            end if
        end do

        ntot = count(jj .gt. 0)
        if (allocated(ii)) deallocate(ii)
        allocate(ii(ntot))

        ii = jj(1:ntot)

        return

    end subroutine get_rep_indices

    subroutine calc_vec_value(val,var,method,mv,wt)

        implicit none

        real(wp),         intent(OUT) :: val
        real(wp),         intent(IN)  :: var(:)
        character(len=*), intent(IN)  :: method
        real(wp),         intent(IN)  :: mv
        real(wp),         intent(IN), optional :: wt(:)

        ! Local variables
        integer  :: ntot
        real(wp) :: mean, variance
        real(wp), allocatable :: wt_now(:)

        ntot = count(var .ne. mv)

        if (ntot .gt. 0) then
            ! Values available for calculations

            allocate(wt_now(size(var)))
            if (present(wt)) then
                wt_now = wt
            else
                wt_now = 1.0_wp
            end if

            where(var .eq. mv) wt_now = 0.0_wp

            select case(trim(method))

                case("sum","mean")
                    ! Calculate a weighted sum/mean with the right weights for each case

                    ! Normalize weights to sum to one
                    if (trim(method) .eq. "mean") wt_now = wt_now / sum(wt_now)

                    val = sum(wt_now*var)

                case("sd")
                    ! Calculate the weighted mean and then weighted standard deviation

                    ! Normalize weights to sum to one
                    wt_now = wt_now / sum(wt_now)

                    if (ntot .ge. 2) then

                        mean     = sum(wt_now*var)
                        variance = real(ntot/(ntot-1),wp) * sum( wt_now*(var-mean)**2 )
                        val      = sqrt(variance)

                    else

                        val = mv

                    end if

                case("min")

                    val = minval(var,mask=var.ne.mv)

                case("max")

                    val = maxval(var,mask=var.ne.mv)

                case DEFAULT

                    write(*,*) "calc_vec_value:: Error: method not recognized."
                    write(*,*) "method = ", trim(method)
                    stop

            end select

        else
            ! No values available in vector, set to missing value

            val = mv

        end if

        return

    end subroutine calc_vec_value

    subroutine varslice_init_nml(vs,filename,group,domain,grid_name,verbose)
        ! Routine to load information related to a given
        ! transient variable, so that it can be processed properly.

        implicit none

        type(varslice_class),   intent(INOUT) :: vs
        character(len=*),       intent(IN)    :: filename
        character(len=*),       intent(IN)    :: group
        character(len=*),       intent(IN), optional :: domain
        character(len=*),       intent(IN), optional :: grid_name
        logical,                intent(IN), optional :: verbose
        ! Local variables

        ! First load parameters from nml file
        call varslice_par_load(vs%par,filename,group,domain,grid_name,verbose)

        ! Perform remaining init operations
        call varslice_init_data(vs)

        return

    end subroutine varslice_init_nml

    subroutine varslice_init_arg(vs,filename,name,units_in,units_out,scale,offset, &
                                                            with_time,time_par)
        ! Routine to load information related to a given
        ! transient variable, so that it can be processed properly.

        implicit none

        type(varslice_class), intent(INOUT) :: vs
        character(len=*),      intent(IN)   :: filename
        character(len=*),      intent(IN)   :: name
        character(len=*),      intent(IN)   :: units_in
        character(len=*),      intent(IN)   :: units_out
        real(wp), optional,    intent(IN)   :: scale
        real(wp), optional,    intent(IN)   :: offset
        logical,  optional,    intent(IN)   :: with_time
        real(wp), optional,    intent(IN)   :: time_par(:)

        ! Local variables

        ! Define parameters from subroutine arguments
        vs%par%filename  = trim(filename)
        vs%par%name      = trim(name)
        vs%par%units_in  = trim(units_in)
        vs%par%units_out = trim(units_out)

        vs%par%unit_scale = 1.0_wp
        if (present(scale)) vs%par%unit_scale = scale

        vs%par%unit_offset = 0.0_wp
        if (present(offset)) vs%par%unit_offset = offset

        vs%par%with_time = .TRUE.
        if (present(with_time)) vs%par%with_time = with_time

        vs%par%time_par = [0.0,0.0,0.0]
        if (present(time_par)) vs%par%time_par = time_par

        ! Perform remaining init operations
        call varslice_init_data(vs)

        return

    end subroutine varslice_init_arg

    subroutine varslice_init_data(vs)

        implicit none

        type(varslice_class), intent(INOUT) :: vs

        ! Local variables
        character(len=12), allocatable :: dim_names(:)
        logical :: with_time

        ! Local shortcut
        with_time = vs%par%with_time

        ! First make sure all data objects are deallocated
        call varslice_end(vs)

        ! Get information from netcdf file
        call nc_dims(vs%par%filename,vs%par%name,dim_names,vs%par%dim)
        vs%par%ndim = size(vs%par%dim,1)

        if (with_time) then

            ! Initialize time vector from user parameters
            call axis_init(vs%time,x0=vs%par%time_par(1), &
                                   x1=vs%par%time_par(2), &
                                   dx=vs%par%time_par(3))

            ! Check to make sure time vector matches netcdf file length
            if (size(vs%time,1) .ne. vs%par%dim(vs%par%ndim)) then
                write(*,*) "varslice_init_data:: Error: generated time coordinate &
                &does not match the length of the time dimension in the netcdf file."
                write(*,*) "time_par:    ", vs%par%time_par
                write(*,*) "size(time):  ", size(vs%time,1)
                write(*,*) "nt (netcdf): ", vs%par%dim(vs%par%ndim)
                write(*,*) "filename:    ", trim(vs%par%filename)
                stop
            end if

        end if

        ! Allocate coordinate and data variables,
        ! load coordinates too
        select case(vs%par%ndim)

            case(1)
                if (with_time) then
                    allocate(vs%var(1,1,1,1))
                else
                    allocate(vs%var(vs%par%dim(1),1,1,1))
                end if
            case(2)
                if (with_time) then
                    allocate(vs%x(vs%par%dim(1)))
                    allocate(vs%var(vs%par%dim(1),1,1,1))

                    if (nc_exists_var(vs%par%filename,dim_names(1))) then
                        call nc_read(vs%par%filename,dim_names(1),vs%x)
                    else
                        call axis_init(vs%x,nx=vs%par%dim(1))
                    end if
                else
                    allocate(vs%x(vs%par%dim(1)))
                    allocate(vs%y(vs%par%dim(2)))
                    allocate(vs%var(vs%par%dim(1),vs%par%dim(2),1,1))

                    if (nc_exists_var(vs%par%filename,dim_names(1))) then
                        call nc_read(vs%par%filename,dim_names(1),vs%x)
                    else
                        call axis_init(vs%x,nx=vs%par%dim(1))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(2))) then
                        call nc_read(vs%par%filename,dim_names(2),vs%y)
                    else
                        call axis_init(vs%y,nx=vs%par%dim(2))
                    end if

                end if

            case(3)
                if (with_time) then
                    allocate(vs%x(vs%par%dim(1)))
                    allocate(vs%y(vs%par%dim(2)))
                    allocate(vs%var(vs%par%dim(1),vs%par%dim(2),1,1))

                    if (nc_exists_var(vs%par%filename,dim_names(1))) then
                        call nc_read(vs%par%filename,dim_names(1),vs%x)
                    else
                        call axis_init(vs%x,nx=vs%par%dim(1))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(2))) then
                        call nc_read(vs%par%filename,dim_names(2),vs%y)
                    else
                        call axis_init(vs%y,nx=vs%par%dim(2))
                    end if

                else
                    allocate(vs%x(vs%par%dim(1)))
                    allocate(vs%y(vs%par%dim(2)))
                    allocate(vs%lev(vs%par%dim(3)))
                    allocate(vs%var(vs%par%dim(1),vs%par%dim(2),vs%par%dim(3),1))

                    if (nc_exists_var(vs%par%filename,dim_names(1))) then
                        call nc_read(vs%par%filename,dim_names(1),vs%x)
                    else
                        call axis_init(vs%x,nx=vs%par%dim(1))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(2))) then
                        call nc_read(vs%par%filename,dim_names(2),vs%y)
                    else
                        call axis_init(vs%y,nx=vs%par%dim(2))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(3))) then
                        call nc_read(vs%par%filename,dim_names(3),vs%lev)
                    else
                        call axis_init(vs%lev,nx=vs%par%dim(3))
                    end if

                end if

            case(4)
                if (with_time) then
                    allocate(vs%x(vs%par%dim(1)))
                    allocate(vs%y(vs%par%dim(2)))
                    allocate(vs%lev(vs%par%dim(3)))
                    allocate(vs%var(vs%par%dim(1),vs%par%dim(2),vs%par%dim(3),1))

                    if (nc_exists_var(vs%par%filename,dim_names(1))) then
                        call nc_read(vs%par%filename,dim_names(1),vs%x)
                    else
                        call axis_init(vs%x,nx=vs%par%dim(1))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(2))) then
                        call nc_read(vs%par%filename,dim_names(2),vs%y)
                    else
                        call axis_init(vs%y,nx=vs%par%dim(2))
                    end if
                    if (nc_exists_var(vs%par%filename,dim_names(3))) then
                        call nc_read(vs%par%filename,dim_names(3),vs%lev)
                    else
                        call axis_init(vs%lev,nx=vs%par%dim(3))
                    end if

                else
                    write(*,*) "varslice_init_data:: 4D array without time dimension is not yet supported."
                    stop
                end if

            case DEFAULT
                write(*,*) "varslice_init_data:: ndim > 4 not allowed."
                write(*,*) "ndim = ", vs%par%ndim
                stop

        end select

        return

    end subroutine varslice_init_data

    subroutine varslice_end(vs)
        ! Deallocate all variables

        implicit none

        type(varslice_class), intent(INOUT) :: vs

        if (allocated(vs%par%dim))  deallocate(vs%par%dim)
        if (allocated(vs%x))        deallocate(vs%x)
        if (allocated(vs%y))        deallocate(vs%y)
        if (allocated(vs%lev))      deallocate(vs%lev)
        if (allocated(vs%time))     deallocate(vs%time)
        if (allocated(vs%var))      deallocate(vs%var)

        return

    end subroutine varslice_end

    subroutine varslice_par_load(par,filename,group,domain,grid_name,init,verbose)

        type(varslice_param_class), intent(OUT) :: par
        character(len=*), intent(IN) :: filename
        character(len=*), intent(IN) :: group
        character(len=*), intent(IN), optional :: domain
        character(len=*), intent(IN), optional :: grid_name
        logical, optional :: init
        logical, optional :: verbose

        ! Local variables
        logical  :: init_pars
        real(wp) :: time_par(3)
        logical  :: print_summary

        init_pars = .FALSE.
        if (present(init)) init_pars = .TRUE.

        print_summary = .TRUE.
        if (present(verbose)) print_summary = verbose

        call nml_read(filename,group,"filename",       par%filename,     init=init_pars)
        call nml_read(filename,group,"name",           par%name,         init=init_pars)
        call nml_read(filename,group,"units_in",       par%units_in,     init=init_pars)
        call nml_read(filename,group,"units_out",      par%units_out,    init=init_pars)
        call nml_read(filename,group,"unit_scale",     par%unit_scale,   init=init_pars)
        call nml_read(filename,group,"unit_offset",    par%unit_offset,  init=init_pars)
        call nml_read(filename,group,"with_time",      par%with_time,    init=init_pars)
        call nml_read(filename,group,"time_par",       par%time_par,     init=init_pars)

        ! Parse filename as needed
        if (present(domain) .and. present(grid_name)) then
            call parse_path(par%filename,domain,grid_name)
        end if

        ! Make sure time parameters are consistent time_par=[x0,x1,dx]
        if (par%time_par(3) .eq. 0) par%time_par(2) = par%time_par(1)

        ! Summary
        if (print_summary) then
            write(*,*) "Loading: ", trim(filename), ":: ", trim(group)
            write(*,*) "filename    = ", trim(par%filename)
            write(*,*) "name        = ", trim(par%name)
            write(*,*) "units_in    = ", trim(par%units_in)
            write(*,*) "units_out   = ", trim(par%units_out)
            write(*,*) "unit_scale  = ", par%unit_scale
            write(*,*) "unit_offset = ", par%unit_offset
            write(*,*) "with_time   = ", par%with_time
            if (par%with_time) then
                write(*,*) "time_par    = ", par%time_par
            end if
        end if

        return

    end subroutine varslice_par_load

    subroutine parse_path(path,domain,grid_name)

        implicit none

        character(len=*), intent(INOUT) :: path
        character(len=*), intent(IN)    :: domain, grid_name

        call nml_replace(path,"{domain}",   trim(domain))
        call nml_replace(path,"{grid_name}",trim(grid_name))

        return

    end subroutine parse_path

    subroutine axis_init(x,x0,x1,dx,nx)

        implicit none

        real(wp), allocatable, intent(OUT) :: x(:)
        real(wp), optional :: x0
        real(wp), optional :: x1
        real(wp), optional :: dx
        integer,  optional :: nx

        ! Local variables
        integer :: i
        real(wp) :: x0_now
        real(wp) :: x1_now
        real(wp) :: dx_now
        integer  :: nx_now

        dx_now = 1.0_wp
        if (present(dx)) dx_now = dx

        x0_now = 0.0_wp
        if (present(x0)) x0_now = x0

        ! Note: if x1 is present, nx is ignored
        if (present(x1)) then
            x1_now = x1
        else if (present(nx)) then
            x1_now = (nx-1)*dx_now
        else
            write(*,*) "axis_init:: Error: either x1 or nx must be present."
            stop
        end if

        if (allocated(x)) deallocate(x)

        nx_now = (x1_now-x0_now)/dx_now + 1
        allocate(x(nx_now))

        do i = 1, nx_now
            x(i) = x0_now + dx_now*real(i-1,wp)
        end do

        return

    end subroutine axis_init

end module varslice


!==================================================================================================
!!
!> @brief       Enabling IADC re-entry campaigns
!> @author      Vitali Braun
!> @author      Christopher Kebschull
!!
!> @date

!!
VB: 16.10.2014 (initial design)

!!
VB: 20.05.2016 (updated to have only statements for all use statements)

!!
CHK: 02.01.2018 (regards NEPTUNE class)
!!
CHK: 04.01.2018 (created Reentry_class)
!!

!!
!> @details     This module contains type definitions, parameters and routines required for
!!              performing re-entry analysis, designed specifically to support IADC re-entry
!!              campaigns using NEPTUNE.
!!
!> @copyright   Institute of Space Systems / TU Braunschweig
!!
!> @anchor      reentry
!!
!!------------------------------------------------------------------------------------------------
module reentry

  use slam_math,    only: rad2deg
  use neptuneClass, only: Neptune_class
  use slam_types,   only: dp
  use slam_time,    only: time_t, mjd2gd

  implicit none

  private

    character(len=*), parameter :: coriginator = 'Wiedemann'                    !> originator of re-entry analysis
    integer,parameter :: LEN_REENTRY_MESSAGE = 1000                             !> length of IADC REDB reentry message

    type, public :: Reentry_class

        logical     :: reEntryInitialised                                       !> initialisation flag
        real(dp)    :: uncertaintyInterval                                      !> 20% uncertainty

    contains

        procedure :: initReEntry
        procedure :: getReEntryMessage
        procedure :: isInitialisedReEntry

    end type Reentry_class

    ! Constructor
    interface Reentry_class
        module procedure constructor
    end interface Reentry_class

contains

    ! ====================================================================
    !!
    !>  @brief      Constructor that should be used to initialize variables.
    !!
    !!  @author     Christopher Kebschull
    !!  @date

    !!
ChK: 04.01.2018 (initial implementation)

    !!

    !!  @anchor     constructor
    !!
    ! --------------------------------------------------------------------
    type(Reentry_class) function constructor()
        constructor%reEntryInitialised = .false.                                !> initialisation flag
        constructor%uncertaintyInterval = 0.2d0                                 !> 20% uncertainty

    end function constructor

!=============================================================================
!
!> @anchor      initReEntry
!!
!> @brief       Initialises this module
!> @author      Vitali Braun
!!
!> @date

!!
 16.10.2014 (initial design)

!!

!!
!-----------------------------------------------------------------------------
  subroutine initReEntry(this)

    class(Reentry_class)    :: this

    !** set initialisation flag
    this%reEntryInitialised = .true.

  end subroutine initReEntry

!=============================================================================
!
!> @anchor      getReEntryMessage
!!
!> @brief       Provides a re-entry report message, which can directly be used for the IADC REDB
!> @author      Vitali Braun
!!
!> @date

!!
 16.10.2014 (initial design)

!!

!!
!-----------------------------------------------------------------------------
  character(len=LEN_REENTRY_MESSAGE) function getReEntryMessage(this,neptune) result(mess)

    class(Reentry_class)                :: this
    type(Neptune_class),intent(inout)   :: neptune

    character(len=140)      :: cdata   ! data string containing reentry information
    integer, dimension(8)   :: date ! date string
    integer                 :: ierr
    real(dp), dimension(4)  :: temp_vec  ! containing re-entry epoch, altitude, latitude and longitude

    type(time_t) :: minCOIW_epoch ! start of COIW
    type(time_t) :: maxCOIW_epoch ! end of COIW
    type(time_t) :: orig_epoch    ! originator epoch
    type(time_t) :: orbit_epoch   ! orbit epoch
    type(time_t) :: reentry_epoch ! re-entry epoch

    ! receive current time
    !--------------------------------------------
    call date_and_time(values=date)
    orig_epoch%year   = date(1)
    orig_epoch%month  = date(2)
    orig_epoch%day    = date(3)
    orig_epoch%hour   = date(5)
    orig_epoch%minute = date(6)
    orig_epoch%second = date(7)

    ! get orbit epoch
    !---------------------------------------------
    call neptune%getStartEpoch(orbit_epoch, ierr)

    ! get COIW epoch
    !---------------------------------------------
    temp_vec = neptune%derivatives_model%getLastPositionECEF()

    reentry_epoch%mjd = temp_vec(1)
    call mjd2gd(reentry_epoch)

    minCOIW_epoch%mjd = reentry_epoch%mjd - this%uncertaintyInterval*(reentry_epoch%mjd-orbit_epoch%mjd)
    maxCOIW_epoch%mjd = reentry_epoch%mjd + this%uncertaintyInterval*(reentry_epoch%mjd-orbit_epoch%mjd)

    call mjd2gd(minCOIW_epoch)
    call mjd2gd(maxCOIW_epoch)

100 format(5(x,i4.4,'/',i2.2,'/',i2.2,x,i2.2,':',i2.2,':',i2.2),x,f7.2,x,f6.2,x,i3,x,i4.4,'/',i2.2,'/',i2.2,x,i2.2,':',i2.2,':',i2.2)

    write(cdata,100) orig_epoch%year, orig_epoch%month, orig_epoch%day, orig_epoch%hour, orig_epoch%minute, int(orig_epoch%second), &
                     orbit_epoch%year, orbit_epoch%month, orbit_epoch%day, orbit_epoch%hour, orbit_epoch%minute, int(orbit_epoch%second), &
                     minCOIW_epoch%year, minCOIW_epoch%month, minCOIW_epoch%day, minCOIW_epoch%hour, minCOIW_epoch%minute, int(minCOIW_epoch%second), &
                     reentry_epoch%year, reentry_epoch%month, reentry_epoch%day, reentry_epoch%hour, reentry_epoch%minute, int(reentry_epoch%second), &
                     maxCOIW_epoch%year, maxCOIW_epoch%month, maxCOIW_epoch%day, maxCOIW_epoch%hour, maxCOIW_epoch%minute, int(maxCOIW_epoch%second), &
                     temp_vec(4)*rad2deg, temp_vec(3)*rad2deg, int(neptune%atmosphere_model%getMinAltitude()), &
                     reentry_epoch%year, reentry_epoch%month, reentry_epoch%day, reentry_epoch%hour, reentry_epoch%minute, int(reentry_epoch%second)

    mess = new_line('a')//repeat('=',160)//new_line('a')//new_line('a')// &
           '  IADC Re-entry campaign - REDB format string:'//new_line('a')//new_line('a')// &
           '  Originator;Origination Epoch;Orbit Epoch;COIW start;COIW;COIW end;longitude/deg;latitude/deg;altitude/km'//new_line('a')// &
           repeat('-',160)//new_line('a')// &
           '  '//coriginator//cdata//new_line('a')//new_line('a')//repeat('=',160)

  end function getReEntryMessage

!=============================================================================
!
!> @anchor      isInitialisedReEntry
!!
!> @brief       Gives the init flag for this module
!> @author      Vitali Braun
!!
!> @date

!!
 16.10.2014 (initial design)

!!

!!
!-----------------------------------------------------------------------------
  logical function isInitialisedReEntry(this)

    class(Reentry_class)    :: this
    isInitialisedReEntry = this%reEntryInitialised

  end function isInitialisedReEntry

end module


!Created by Stuart Davie
!********************************************************************************************************
! Version 1  : Takes sets of microsolvated systems represented in spherical coordinates and reorders water molecules
!               based on proximity to nodes. If no nodes are input, orders by distance to central molecule. Can also strip water
!		molecules from training set if desired.
! Version 1.1: Notifies user when no node file is present and creates example file. Gives user option to strip waters from set.
! Version 1.2: Modularization by J. L. McDonagh, September 2016
!
! CHANGE LOG
! Version 1.1 Addtional error warnings and user output
! Version 1.2 Modularization for incorporation into HERMES.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module solorder
implicit none

contains

subroutine solvent_order(TSname, AtomsBefore, NoWaters)
Character 		::	TSname*50,DummyChar*50
integer 		::	AtomsBefore, NoWaters, configNo, i,j,water_min,NoNodes,NoStrip,ios
real, allocatable 	:: 	raw(:),rawsort(:),waterfeatures(:,:),waterfeatsort(:,:),waterfeatsort2(:,:)
real, allocatable 	:: 	cartesians(:,:),NodeCarts(:,:),NodeFeats(:,:),nodeorder(:)
integer, allocatable 	:: 	nodelist(:),orderlist(:)
double precision        ::      b2a

b2a=0.529177249
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!call system('ls')									!Read input parameters
!print*,'Training Set Name?'								!
!read*,TSNAME										!
!print*,'No. of atoms before waters?'							!
!read*,AtomsBefore									!
!print*,'No. of waters?'									!
!read*,NoWaters
!print*,'Strip no. of waters? ("0" to leave all waters in)'
!read*,NoStrip									!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!open(unit=11,file='solv_input.txt',status='old',iostat=ios)
!if(ios.eq.0) then
!   read(11,*)DummyChar,TSname
!   read(11,*)DummyChar,AtomsBefore
!   read(11,*)DummyChar,NoWaters
!else
!   print*,'error reading solv_input.txt'
!endif
!close(11)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
allocate(raw((AtomsBefore+3*NoWaters)*3-6+27))						!

allocate(waterfeatures(NoWaters,9))							!
allocate(waterfeatsort(NoWaters,9))							!Allocate arrays and initialize variables
allocate(waterfeatsort2(NoWaters,9))							!
allocate(cartesians(NoWaters,9))							!
allocate(NodeCarts(NoWaters,3))								!
allocate(NodeFeats(NoWaters,3))								!
allocate(nodelist(NoWaters))								!
allocate(nodeorder(NoWaters))								!
allocate(orderlist(NoWaters))								!
configNo   =	0									!
NodeFeats  = 	0									!
									!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
open(unit=4,file='node_feats_cut.txt',status='old',err=100,iostat=ios)			!
read(4,*)NoNodes
NoStrip=NoWaters-NoNodes									!
allocate(rawsort((AtomsBefore+(3*(NoWaters-NoStrip)))*3-6+27))					!
rawsort    = 	0

print*,'Number of waters to strip',NoStrip
read(4,*)										!Read input nodes if they exist
do i=1,NoNodes										!(otherwise NodeFeats=0 from above)
	read(4,*,err=100,end=100)NodeFeats(i,:)						!
enddo											!
close(4)										!
100 continue										!
if(ios.gt.0)then
NoNodes=NoWaters									!
print*,'Something wrong with node_feats_cut.txt. Positioning nodes at the origin'		!
open(unit=4,file='node_feats_cut.txt_example',status='unknown')				!
write(4,*)NoNodes;write(4,*);								!
do i=1,NoNodes										!
	write(4,*)NodeFeats(i,:)							!
enddo											!
close(4)										!
endif											!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

open(unit=3, file='node_carts_cut.txt', status='unknown')
write(3,*)NoNodes
write(3,*)'Selected Nodes'
open(unit=1, file=trim(TSNAME), status='old')
open(unit=2, file=trim(TSNAME)//'_new', status='unknown')
!!*********************MAIN FEATURE REDEFINITION LOOP*************************************************!!!!!!!!!!!
do while (.true.)												!For every configuration:
   read(1,*,err=101,end=101)raw											!read in features
   configNo=configNo+1												!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   do i=1,NoWaters												!
      do j=1,9								!					!
         waterfeatures(i,j)=raw((atomsBefore*3-6)+(9*(i-1)+j))		!get the features of the waters		!convert water features to cartesians
      enddo								!					!
      cartesians(i,1)=waterfeatures(i,1)*sin(waterfeatures(i,2))*cos(waterfeatures(i,3))!convert to		!
      cartesians(i,2)=waterfeatures(i,1)*sin(waterfeatures(i,2))*sin(waterfeatures(i,3))!cartesians		!
      cartesians(i,3)=waterfeatures(i,1)*cos(waterfeatures(i,2))			!			!
      NodeCarts(i,1)=NodeFeats(i,1)*sin(NodeFeats(i,2))*cos(NodeFeats(i,3))	!also convert node		!convert node features to cartesians
      NodeCarts(i,2)=NodeFeats(i,1)*sin(NodeFeats(i,2))*sin(NodeFeats(i,3))	!coords to cartesians		!
      NodeCarts(i,3)=NodeFeats(i,1)*cos(NodeFeats(i,2))				!				!
      if(configNo.eq.1)  then
         if(i.le.NoNodes) write(3,*)'Ne',NodeCarts(i,1)*b2a,NodeCarts(i,2)*b2a,NodeCarts(i,3)*b2a!output node carts		!
      endif
   enddo													!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   do i=1,NoWaters												!
      do j=1,NoWaters												!for each node  {
         nodeorder(j)=sqrt((cartesians(j,1)-NodeCarts(i,1))**2+(cartesians(j,2)-NodeCarts(i,2))**2+&		!find distance between waters and node
         &(cartesians(j,3)-NodeCarts(i,3))**2)		!Make array of water to current node distances		!
      enddo						!							!
      do j=1,i-1				      !orderlist() is the list of already allocated water mols	!determine closest water not already taken
         nodeorder(orderlist(j))=2*maxval(nodeorder)  !This loop sets such h20 mols to high value so they are 	!by other node
      enddo					      !not selected as closest to current node			!
      orderlist(i)=minloc(nodeorder,1) 		!Finds closest h2o to node					!list water appropriately   }
      waterfeatsort(i,:)=waterfeatures(orderlist(i),:)!Lists waters according to order				!
   enddo													!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   do i=1,NoWaters												!
      do j=1,3							!						!
         waterfeatsort2(i,j)=waterfeatsort(i,j)			!						!
      enddo							!						!Reorder hydrogens based on distance
      if(waterfeatsort(i,4).lt.waterfeatsort(i,7)) then		!IF first hydrogen is nearer than second	!to atom of interest
         waterfeatsort2(i,4:9)=waterfeatsort(i,4:9)		!list hydrogens in current order		!
      else							!ELSE						!
         waterfeatsort2(i,3:6)=waterfeatsort(i,6:9)		!swap the hydrogens in the list			!
         waterfeatsort2(i,6:9)=waterfeatsort(i,3:6)		!						!
      endif							!						!
   enddo													!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   rawsort(1:atomsbefore*3-6)=raw(1:atomsbefore*3-6)		!rawsort will be the node-defined		!
   rawsort((atomsbefore*3-6+1):((atomsbefore+3*(NoWaters-NoStrip))*3-6))=0!feature set.Set h2o=0 so errors seeable!
   rawsort(size(rawsort)-27+1:size(rawsort))=raw(size(raw)-27+1:size(raw))
   do i=1,NoWaters-NoStrip											!
      do j=1,9													!Get all new ordering
         rawsort((atomsBefore*3-6)+(9*(i-1)+j))=waterfeatsort2(i,j)	!New order from waterfeatsort2		!
      enddo													!
   enddo													!
   write(2,*)rawsort							!Output new training set		!and output to appropriate file
enddo														!
101 continue													!
!!*********************END MAIN FEATURE REDEFINITION LOOP*********************************************!!!!!!!!!!!
print*,'Total configs =',configNo
call system('mv '//trim(TSNAME)//' '//trim(TSNAME)//'_sorted_unstripped')		!Rename new and old training sets so they
call system('mv '//trim(TSNAME)//'_new '//trim(TSNAME))				!are immediately ferebus compatable

end subroutine solvent_order

end module solorder


*
*     -------------------------------------------------------------
*      T W O P A R T I C L E 3 2
*     -------------------------------------------------------------
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
*     OF TWO PARTICLE OPERATOR IN CASE :       N'1 = N1 - 1        *
*                                              N'2 = N2 + 1        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      SUBROUTINE TWOPARTICLE32(IA,IB,IIA,IIB,IIC,IID)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      COMMON/TRK/BD1(3),BD2(3),BK1(3),BK2(3),
     *ID1(7),ID2(7),IK1(7),IK2(7)
      COMMON/PERMAT/IRS(2,2),IRL(20,20),RS(2,2),RL(20,20)
      COMMON/KAMPAS/ IW1(2,20),IW2(2,20),IWAA(2,2,20,20),
     :RW1(2,20),RW2(2,20),RWAA(2,2,20,20)
      COMMON /CASEOP/ IOCASE
      EXTERNAL TWO32
      IF(IHSH.LE.1)RETURN
      CALL HIBFF(IA,IB,IA,IA,2)
      IF(ITTK(1,IK1(6),ID1(6)).EQ.0) RETURN
      IF(ITTK(2*IK1(3),IK1(5),ID1(5)).EQ.0) RETURN
      IF(IABS(IK2(6)-ID2(6)).GT.3) RETURN
      IF(IABS(IK2(5)-ID2(5)).GT.6*IK2(3)) RETURN
      IF(IOCASE.EQ.1) THEN
* Spin-Spin operator
        IP=ITREXG2(LJ(IA),LJ(IB),LJ(IB),LJ(IB),IKK)+1
      ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
        IP=ITREXG(LJ(IA),LJ(IB),LJ(IB),LJ(IB),IKK)+1
      ENDIF
      IF(IKK.LE.0)RETURN
      IG=IP+IKK-1
      DO 2 I1=1,2
        IRS(I1,1)=0
        DO 3 I2=1,20
          IRL(I2,1)=0
          DO 4 I3=1,2
            DO 5 I4=1,20
	      IWAA(I1,I3,I2,I4)=0
    5       CONTINUE
    4     CONTINUE
    3   CONTINUE
    2 CONTINUE
      DO 1 I=IP,IG
        KL=I-1
*
        IF(IOCASE.EQ.1) THEN
* Spin-spin operator
          CALL SSC(IG,KL,IA,IB,IB,IB,IB,IB,IB,IA,KL,TWO32)
        ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
          CALL SOOC(IG,KL,IA,IB,IB,IB,IB,IB,IB,IA,KL,TWO32)
        ENDIF
*
    1 CONTINUE
      RETURN
      END


! (C) Copyright 2017-2020 UCAR
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

module fv3jedi_io_latlon_mod

use iso_c_binding

use netcdf
use mpi

use atlas_module, only: atlas_field, atlas_fieldset

use datetime_mod

use fckit_configuration_module, only: fckit_configuration
use fckit_log_module, only : log
use fckit_mpi_module
use fv3jedi_constants_mod, only: rad2deg

use type_bump, only: bump_type

use fv3jedi_constants_mod,    only: rad2deg
use fv3jedi_bump_interp_mod,  only: fv3jedi_bump_interp
use fv3jedi_field_mod,        only: fv3jedi_field
use fv3jedi_geom_mod,         only: fv3jedi_geom
use fv3jedi_kinds_mod,        only: kind_int, kind_real
use fv3jedi_io_utils_mod,     only: vdate_to_datestring, replace_text
use fv3jedi_netcdf_utils_mod, only: nccheck

implicit none

private
public fv3jedi_llgeom!, create_latlon, delete_latlon, write_latlon_metadata, write_latlon_fields, &

!Module level type
type fv3jedi_llgeom
 type(fckit_mpi_comm) :: f_comm
 type(fv3jedi_bump_interp) :: bump
 integer :: llcomm
 integer :: layout(2)
 logical :: thispe = .false.
 integer :: nx, ny, nxg, nyg
 integer :: npes
 real(kind=kind_real), allocatable :: lons(:)
 real(kind=kind_real), allocatable :: lats(:)
 character(len=1024) :: filename
 integer, allocatable :: istart2(:), icount2(:)
 integer, allocatable :: istart3(:), icount3(:)
 integer, allocatable :: istarte(:), icounte(:)
 contains
  procedure :: setup_conf
  procedure :: setup_date
  procedure :: write
  procedure :: delete
  final :: dummy_final
end type fv3jedi_llgeom

contains

! --------------------------------------------------------------------------------------------------
subroutine setup_conf(self, geom)

implicit none

!Arguments
class(fv3jedi_llgeom),     intent(inout) :: self
type(fv3jedi_geom),        intent(in)    :: geom          !< Geometry

call log%debug("fv3jedi_io_latlon_mod%setup_conf starting")

call create_latlon(self, geom)

call log%debug("fv3jedi_io_latlon_mod%setup_conf done")

end subroutine setup_conf

! --------------------------------------------------------------------------------------------------

subroutine setup_date(self, vdate)

implicit none

!Arguments
class(fv3jedi_llgeom),     intent(inout) :: self
type(datetime),            intent(in)    :: vdate         !< DateTime

integer :: n
character(len=4) :: yyyy
character(len=2) :: mm, dd, hh, min, ss

call log%debug("fv3jedi_io_latlon_mod%setup_date starting")

call log%debug("fv3jedi_io_latlon_mod%setup_date done")

end subroutine setup_date

! --------------------------------------------------------------------------------------------------

subroutine delete(self)

implicit none
class(fv3jedi_llgeom), intent(inout) :: self

call log%debug("fv3jedi_io_latlon_mod%delete starting")

call delete_latlon(self)

call log%debug("fv3jedi_io_latlon_mod%delete done")

end subroutine delete

! --------------------------------------------------------------------------------------------------

subroutine write(self, geom, fields, f_conf, vdate)

implicit none
class(fv3jedi_llgeom),     intent(inout) :: self
type(fv3jedi_geom),        intent(in)    :: geom          !< Geom
type(fv3jedi_field),       intent(in)    :: fields(:)     !< Fields to be written
type(fckit_configuration), intent(in)    :: f_conf        !< Configuration
type(datetime),            intent(in)    :: vdate         !< DateTime

integer :: var

call log%debug("fv3jedi_io_latlon_mod%write starting")

call write_latlon_metadata(self, geom, f_conf, vdate)

call write_latlon_fields(self, geom, fields)

call log%debug("fv3jedi_io_latlon_mod%write done")

end subroutine write

! --------------------------------------------------------------------------------------------------

subroutine create_latlon(llgeom, geom)

implicit none

!Arguments
type(fv3jedi_llgeom), intent(inout) :: llgeom   !< LatLon Geometry
type(fv3jedi_geom),   intent(in)    :: geom     !< Geometry

integer :: color

real(kind=kind_real) :: dx, dy
integer :: i, j, ji, jj, ii, locs_nlocs, ierr
real(kind=kind_real), allocatable :: locs_lat(:), locs_lon(:)

! Create lat lon grid and interpolation object for going from cube to lat-lon
! --------------------------------------------------------------------------

llgeom%f_comm = geom%f_comm

!Maximum of 12 IO processors
if (llgeom%f_comm%size() >= 12) then
  llgeom%layout(1) = 12
  llgeom%layout(2) = 1
elseif (llgeom%f_comm%size() >= 6) then
  llgeom%layout(1) = 6
  llgeom%layout(2) = 1
else
  call abor1_ftn("create_latlon error: fewer than 6 npes not anticipated")
endif
llgeom%npes = llgeom%layout(1) * llgeom%layout(2)

!Since the lat lon grid is only for IO purposes it is only
!defined on a subset of PEs - those that will do the writing.
!This is generally more efficient than having many PEs trying
!to write to the same file.

llgeom%nxg = 4*(geom%npx - 1)
llgeom%nyg = 2*(geom%npy - 1) + 1
llgeom%nx = 0
llgeom%ny = 0

color = MPI_UNDEFINED

if (llgeom%f_comm%rank() <= llgeom%npes-1) then

  !Split communicator
  color = int(llgeom%f_comm%communicator() / 2)

  llgeom%thispe = .true.

  !Resolution
  dx = 360.0_kind_real / (real(llgeom%nxg,kind_real) - 1.0_kind_real)
  dy = 180.0_kind_real / (real(llgeom%nyg,kind_real) - 1.0_kind_real)

  llgeom%nx = llgeom%nxg / llgeom%layout(1)
  llgeom%ny = llgeom%nyg / llgeom%layout(2)

  allocate(llgeom%lons(llgeom%nx))
  allocate(llgeom%lats(llgeom%ny))

  !Each processor has subset of lons
  llgeom%lons(1) = dx * llgeom%nx * llgeom%f_comm%rank()
  do i = 2,llgeom%nx
    llgeom%lons(i) = llgeom%lons(i-1) + dx
  enddo

  !Each processor has all lats
  llgeom%lats(1) = -90.0_kind_real
  do i = 2,llgeom%ny
    llgeom%lats(i) = llgeom%lats(i-1) + dy
  enddo

  locs_nlocs = llgeom%nx*llgeom%ny
  allocate(locs_lon(locs_nlocs))
  allocate(locs_lat(locs_nlocs))

  ii = 0
  do jj = 1,llgeom%ny
    do ji = 1,llgeom%nx
      ii = ii + 1
      locs_lon(ii) = llgeom%lons(ji)
      locs_lat(ii) = llgeom%lats(jj)
    enddo
  enddo

else

  locs_nlocs = 0
  allocate(locs_lon(0))
  allocate(locs_lat(0))

endif

call llgeom%bump%setup(geom%f_comm, geom%isc, geom%iec, geom%jsc, geom%jec, geom%npz, &
                       geom%grid_lon(geom%isc:geom%iec, geom%jsc:geom%jec), &
                       geom%grid_lat(geom%isc:geom%iec, geom%jsc:geom%jec), &
                       locs_nlocs, locs_lon, locs_lat)

deallocate(locs_lon)
deallocate(locs_lat)

!IO communicator
!call MPI_Comm_split(llgeom%f_comm%communicator(), color, llgeom%f_comm%rank(), llgeom%llcomm, ierr)

! NC arrays
allocate(llgeom%istart3(4),llgeom%icount3(4))
allocate(llgeom%istarte(4),llgeom%icounte(4))
allocate(llgeom%istart2(3),llgeom%icount2(3))
llgeom%istart3(1) = llgeom%nx * llgeom%f_comm%rank() + 1;  llgeom%icount3(1) = llgeom%nx
llgeom%istart3(2) = 1;                                     llgeom%icount3(2) = llgeom%ny
llgeom%istart3(3) = 1;                                     llgeom%icount3(3) = geom%npz
llgeom%istart3(4) = 1;                                     llgeom%icount3(4) = 1
llgeom%istart2(1) = llgeom%istart3(1);                     llgeom%icount2(1) = llgeom%icount3(1)
llgeom%istart2(2) = llgeom%istart3(2);                     llgeom%icount2(2) = llgeom%icount3(2)
llgeom%istart2(3) = llgeom%istart3(4);                     llgeom%icount2(3) = llgeom%icount3(4)

llgeom%istarte = llgeom%istarte
llgeom%icounte = llgeom%icount3
llgeom%istarte(3) = geom%npz + 1

end subroutine create_latlon

! --------------------------------------------------------------------------------------------------

subroutine delete_latlon(llgeom)

implicit none

!Arguments
type(fv3jedi_llgeom), intent(inout) :: llgeom  !< LatLon Geometry

if (llgeom%thispe) then
  deallocate(llgeom%lons)
  deallocate(llgeom%lats)

  deallocate ( llgeom%istart2, llgeom%icount2 )
  deallocate ( llgeom%istart3, llgeom%icount3 )
  deallocate ( llgeom%istarte, llgeom%icounte )
endif

call llgeom%bump%delete()

end subroutine delete_latlon

! --------------------------------------------------------------------------------------------------

subroutine write_latlon_metadata(llgeom, geom, f_conf, vdate)

implicit none

!Arguments
type(fv3jedi_llgeom),      intent(inout) :: llgeom   !< LatLon Geometry
type(fv3jedi_geom),        intent(in)    :: geom     !< Geometry
type(fckit_configuration), intent(in)    :: f_conf   !< Configuration
type(datetime),            intent(in)    :: vdate    !< DateTime

integer :: date(6)
integer(kind=c_int) :: idate, isecs
character(len=64)   :: datefile

integer :: ncid, varid(2)
integer :: x_dimid, y_dimid, z_dimid, e_dimid, t_dimid
character(len=:), allocatable :: str

! Current date
call datetime_to_ifs(vdate, idate, isecs)
date(1) = idate/10000
date(2) = idate/100 - date(1)*100
date(3) = idate - (date(1)*10000 + date(2)*100)
date(4) = isecs/3600
date(5) = (isecs - date(4)*3600)/60
date(6) = isecs - (date(4)*3600 + date(5)*60)

! Naming convention for the file
llgeom%filename = 'Data/fv3jedi.latlon.'
if (f_conf%has("filename")) then
   call f_conf%get_or_die("filename",str)
   llgeom%filename = str
   deallocate(str)
endif

! Append filename with the curent datetime from fv3jedi
write(datefile,'(I4,I0.2,I0.2,A1,I0.2,I0.2,I0.2)') date(1),date(2),date(3),"_",date(4),date(5),date(6)
llgeom%filename = trim(llgeom%filename)//trim(datefile)//trim("z.nc4")

call nccheck( nf90_create( llgeom%filename, ior(NF90_NETCDF4, NF90_MPIIO), ncid, &
                           comm = llgeom%f_comm%communicator(), info = MPI_INFO_NULL), "nf90_create" )

! Create dimensions
call nccheck ( nf90_def_dim(ncid, "lon" , llgeom%nxg , x_dimid), "nf90_def_dim lon" )
call nccheck ( nf90_def_dim(ncid, "lat" , llgeom%nyg , y_dimid), "nf90_def_dim lat" )
call nccheck ( nf90_def_dim(ncid, "lev" , geom%npz   , z_dimid), "nf90_def_dim lev" )
call nccheck ( nf90_def_dim(ncid, "edge", geom%npz+1 , e_dimid), "nf90_def_dim lev" )
call nccheck ( nf90_def_dim(ncid, "time", 1          , t_dimid), "nf90_def_dim time" )

! Define fields to be written (geom)
call nccheck( nf90_def_var(ncid, "lons", NF90_DOUBLE, x_dimid, varid(1)), "nf90_def_var lons" )
call nccheck( nf90_def_var(ncid, "lats", NF90_DOUBLE, y_dimid, varid(2)), "nf90_def_var lats" )

call nccheck( nf90_enddef(ncid), "nf90_enddef" )

if (llgeom%thispe) then

  ! Write fields (geom)
  call nccheck( nf90_put_var( ncid, varid(1), llgeom%lons, &
                              start = llgeom%istart2(1:1), count = llgeom%icount2(1:1) ), "nf90_put_var lons" )
  call nccheck( nf90_put_var( ncid, varid(2), llgeom%lats, &
                              start = llgeom%istart2(2:2), count = llgeom%icount2(2:2) ), "nf90_put_var lats" )

endif

! Close file
call nccheck( nf90_close(ncid), "nf90_close" )

!Let LatLon PEs catch up
call llgeom%f_comm%barrier()

end subroutine write_latlon_metadata

! --------------------------------------------------------------------------------------------------

subroutine write_latlon_fields(llgeom, geom, fields)

implicit none

!Arguments
type(fv3jedi_llgeom), target, intent(inout)   :: llgeom         !< LatLon Geometry
type(fv3jedi_geom),           intent(in)      :: geom           !< Geometry
type(fv3jedi_field),          intent(in)      :: fields(:)      !< Field to write

integer :: var, ji, jj, jk, csngrid, llngrid, ii, i, j, k, n
real(kind=kind_real), allocatable :: llfield_bump(:,:)
real(kind=kind_real), allocatable :: llfield(:,:,:)

integer :: ncid, varid
integer :: x_dimid, y_dimid, z_dimid, e_dimid, t_dimid
integer, target  :: dimids3(4), dimids2(3), dimidse(4)
integer, pointer :: dimids(:), istart(:), icount(:)

! Loop over fields
! ----------------
do var = 1, size(fields)

  ! Only certain fields can be written for now
  ! ------------------------------------------
  if ( trim(fields(var)%space) == 'magnitude' .and. &
       trim(fields(var)%staggerloc) == 'center' .and. &
       .not. fields(var)%integerfield ) then

    ! Interpolate the field to the lat-lon grid
    ! -----------------------------------------
    if (llgeom%thispe) then
     allocate(llfield(1:llgeom%nx,1:llgeom%ny,1:geom%npz))
    else
     allocate(llfield(0,0,0))
    endif
    llfield = 0.0_kind_real

    csngrid = (geom%iec-geom%isc+1)*(geom%jec-geom%jsc+1)
    llngrid = llgeom%nx*llgeom%ny

    !Allocate fields with BUMP arrangement
    allocate(llfield_bump(llngrid,geom%npz))

    !Bilinear interpolation to latlon grid
    call llgeom%bump%apply(geom%npz, fields(var)%array, llngrid, llfield_bump)

    !Unpack BUMP latlon field
    if (llgeom%thispe) then
     do jk = 1, geom%npz
       ii = 0
       do jj = 1,llgeom%ny
         do ji = 1,llgeom%nx
           ii = ii + 1
           llfield(ji,jj,jk) = llfield_bump(ii,jk)
         enddo
       enddo
     enddo
    endif

    !Open file
    call nccheck( nf90_open( llgeom%filename, ior(NF90_WRITE, NF90_MPIIO), ncid, &
                            comm = llgeom%f_comm%communicator(), info = MPI_INFO_NULL), "nf90_open" )

    !Dimension ID
    call nccheck( nf90_inq_dimid(ncid, "lon" , x_dimid), "nf90_inq_dimid lon" )
    call nccheck( nf90_inq_dimid(ncid, "lat" , y_dimid), "nf90_inq_dimid lat" )
    call nccheck( nf90_inq_dimid(ncid, "lev" , z_dimid), "nf90_inq_dimid lev" )
    call nccheck( nf90_inq_dimid(ncid, "edge", e_dimid), "nf90_inq_dimid edge" )
    call nccheck( nf90_inq_dimid(ncid, "time", t_dimid), "nf90_inq_dimid time" )

    dimids3 =  (/ x_dimid, y_dimid, z_dimid, t_dimid /)
    dimidse =  (/ x_dimid, y_dimid, e_dimid, t_dimid /)
    dimids2 =  (/ x_dimid, y_dimid, t_dimid /)

    ! Pointer to dimensions based on number of levels
    if (associated(dimids)) nullify(dimids)
    if (associated(istart)) nullify(istart)
    if (associated(icount)) nullify(icount)
    if (fields(var)%npz == geom%npz) then
      dimids => dimids3
      istart => llgeom%istart3
      icount => llgeom%icount3
    elseif (fields(var)%npz == 1) then
      dimids => dimids2
      istart => llgeom%istart2
      icount => llgeom%icount2
    elseif (fields(var)%npz == geom%npz+1) then
      dimids => dimidse
      istart => llgeom%istarte
      icount => llgeom%icounte
    endif

    if (associated(dimids)) then

      ! Write field to the file
      call nccheck( nf90_def_var( ncid, trim(fields(var)%short_name), NF90_DOUBLE, dimids, varid), &
                    "nf90_def_var"//trim(fields(var)%short_name) )
      call nccheck( nf90_put_att(ncid, varid, "long_name", trim(fields(var)%long_name) ), "nf90_put_att" )
      call nccheck( nf90_put_att(ncid, varid, "units"    , trim(fields(var)%units)     ), "nf90_put_att" )
      call nccheck( nf90_enddef(ncid), "nf90_enddef" )

      if (llgeom%thispe) then
       call nccheck( nf90_put_var( ncid, varid, llfield, start = istart, count = icount), &
                     "nf90_put_var"//trim(fields(var)%short_name) )
      endif

    endif

    ! Close file
    call nccheck( nf90_close(ncid), "nf90_close" )

    !Let LatLon PEs catch up
    call llgeom%f_comm%barrier()

    deallocate(llfield)
    deallocate(llfield_bump)

  endif

enddo

end subroutine write_latlon_fields

! --------------------------------------------------------------------------------------------------

subroutine dummy_final(self)
type(fv3jedi_llgeom), intent(inout) :: self
end subroutine dummy_final

! --------------------------------------------------------------------------------------------------

end module fv3jedi_io_latlon_mod