      SUBROUTINE HOLCAL( NIN, NOUT, LERR, CPOINT, CVECT, SAMPLE,
     &                   MCSTEP, MCKTIN, MCLEN,
     &			 ATMAX, ATNO, ATBRK, ATRES, ATCHN, ATRNO,
     &			 ATXYZ, ATVDW, ATBND, ATRAD2,
     &                   PI, LDBUG, SHYDRA, FHYDRA, SPDBSP, FPDBSP,
     &			 LLINE, LCAPS, LSPHBX, SHORTO,
     &			 STRMAX, STRNOP, STRNON, STRCEN, STRRAD,
     &			 STRLVC, STRLBO, STRSBO, STRBRD,
     &			 ENDRAD, CUTSIZE, CONNR, PERPVE, PERPVN,
     &			 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) 1995 Oliver Smart & Birkbeck College,                        *
C * All rights reserved                                              *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1997 Oliver Smart                    *
C ********************************************************************
C
C Modification history:
C
C Date  Author          Modification
C 11/95 O.S. Smart      Original version
C 15/11/95 split off HOLE calculation into seperate s/r
C 10/97 O.S. Smart      CAPSULE WARNING changed to include 'plain english'
C 12/97 O.S.S.		cut off lists introduced to speed calculations
C			change here is vble cutsize
C 01/00 O.S.S.    	CONN option introduced
C

C passed vbles *****************

C input/output stream numbers
      INTEGER			NIN, NOUT

C error indicator
      LOGICAL			LERR

C an initial point in the channel
C (must be specified)
      DOUBLE PRECISION          CPOINT(3)

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

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

C the number of steps to be taken
C on each Monte Carlo application
      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 maximum no. of atoms
      INTEGER                   ATMAX

C number of atoms read in from each file:
      INTEGER                   ATNO

C atom names found in Brookhaven file:
      CHARACTER*4               ATBRK(ATMAX)

C residue name in brook
      CHARACTER*3               ATRES(ATMAX)

C chain identifier in brookhaven pdb file
      CHARACTER*1               ATCHN(ATMAX)

C integer residue no.
      INTEGER                   ATRNO(ATMAX)

C co-ordinates
      DOUBLE PRECISION          ATXYZ( 3, ATMAX)

C vdw and bond radii of each atoms
      DOUBLE PRECISION          ATVDW(ATMAX), ATBND(ATMAX)

C 16/6/94 - spherebox option.
C s/r ****** needs vble ATRAD as store of the
C radius squared between the centre of boxsphere and
C each atom to avoid unnecessary calc
      DOUBLE PRECISION          ATRAD2( ATMAX)

C will need PI
      DOUBLE PRECISION          PI

C logical vairable - produce debug output
      LOGICAL                   LDBUG

C hydra binary plot output file, a stream for it
C default to none - indicated by setting FHYDRA(1:4) to 'NONE'
      CHARACTER*200             FHYDRA
      INTEGER                   SHYDRA

C pdb format output file 'atoms' are sphere centres
C default to none by setting FPDBSP to 'NONE'
      CHARACTER*200             FPDBSP
      INTEGER                   SPDBSP

C vbles to turn on the sphere-box, capsule options
      LOGICAL			LSPHBX, LCAPS

C flags to turn on/off:
C the writing of lines joining sphere surfaces to the two closest atoms,
      LOGICAL			LLINE

C 11/95 introduce new variable to reduce text output -
C if oshort =
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 store for sphere centres and radii
C store the initial point as no 0 and subseqently points in the +ve
C bit. Points below the initial point are stored in -ve bit.
C maximum number of entries
      INTEGER                   STRMAX
C the no. of entries, +Ve entries -Ve entries
      INTEGER                   STRNOP, STRNON
C the centres and radii
      DOUBLE PRECISION          STRCEN(3,-STRMAX:STRMAX),
     &                          STRRAD(-STRMAX:STRMAX)

C 08/07/94
C vbles to store the dimensions found in the spherebox
C options.
C (N.B. for capsule strlvc is the second centre, strbrd capsule radius)
      DOUBLE PRECISION          STRLVC(3,-STRMAX:STRMAX),
     &                          STRLBO(-STRMAX:STRMAX),
     &                          STRSBO(-STRMAX:STRMAX),
     &                          STRBRD(-STRMAX:STRMAX)

C New option 22/11/93 - For wide channels need to
C be able to specify the radius at which an end is reached
      DOUBLE PRECISION          ENDRAD

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 .85 angs
      DOUBLE PRECISION		CONNR(2)

C unit vectors in plane normal to cvect
C needed to a number of routines - originally h2dmap but now conn
C and addend
C these are normal - first is east direction (x on plane)
C                    and second is north     (y on plane)
C return unchanged!!!
      DOUBLE PRECISION		PERPVE(3), PERPVN(3)

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 current sphere centre,
C the energy of this point - energy is minus the largest sphere
C which can be centered at this point without vdW overlap
      DOUBLE PRECISION          CURCEN(3), CURENG
      INTEGER                   CURSTP

C the lowest energy point found, step number
      DOUBLE PRECISION          LOWCEN(3), LOWENG
      INTEGER                   LOWSTP

C a new point
      DOUBLE PRECISION          NEWCEN(3), NEWENG

C 17/6/94
C variables for lsphbx option
C ***LVC is the long axis vector
C ***LBO is the box dimension of the long side (direction ***LRD)
C ***SBO is the box dimension of the short side
C        n.b. the other dimension along CVECT is set to the long value ***LBO
C ***BRD is the spherebox radius
      DOUBLE PRECISION          CURLVC(3), NEWLVC(3), LOWLVC(3),
     &                          CURLBO,    NEWLBO,    LOWLBO,
     &                          CURSBO,    NEWSBO,    LOWSBO,
     &                          CURBRD,    NEWBRD,    LOWBRD

C Monte Carlo acceptance factor, starting value MCKTIN
      DOUBLE PRECISION          MCKT

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 loop counts
      INTEGER                   ICOUNT

C number of rejections
      INTEGER                   NREJ
C atom list no. with smallest dist-vdw radius, 2nd smallest
C 07/06/94 as iat's may or may not be supplied with previously
C found numbers then we can use this to speed up the procedure
C Dec 97 add iat3
      INTEGER			IAT1, IAT2, IAT3

C 2nd/3rd smallest distance-vdw radius (of iat2/3)
      DOUBLE PRECISION		DAT2, DAT3

C a real number, a probability, the random number to test it
      DOUBLE PRECISION          HGOOD, PROB, RANDYN

C record number
      INTEGER                   IREC

C number of steps of sd min apply in spherebox option
      LOGICAL                   NOSTEP

C equivalent radius for connolly routine
      DOUBLE PRECISION		REQUIV

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

! if we are doing PEG_WRITEALL then need to output vital channel statistics
! to top of sph file
      IF (PEG_WRITEALL)
     &   CALL PEG_WRITEALL_HEADER( FPDBSP, SPDBSP, SAMPLE,
     &		    		   CVECT, PERPVE, PERPVN,
     &				   CONNR, ENDRAD )

C the initial sphere centre is cpoint
      LOWCEN(1) = CPOINT(1)
      LOWCEN(2) = CPOINT(2)
      LOWCEN(3) = CPOINT(3)
C if doing capsule option the second point starts at the same point
      IF (LCAPS) THEN
        LOWLVC(1) = LOWCEN(1)
        LOWLVC(2) = LOWCEN(2)
        LOWLVC(3) = LOWCEN(3)
      ENDIF

C line 10 - do until the end of channel is found
10    CONTINUE

C 20/11/95 flush the output stream
        IF (NOUT.EQ.6) CALL FLUSH6

C do MCSTEP steps of Monte Carlo
      	DO 20 ICOUNT = 1, MCSTEP

C on first step new point is LOWCEN
          IF (ICOUNT.EQ.1) THEN
            NEWCEN(1) = LOWCEN(1)
            NEWCEN(2) = LOWCEN(2)
            NEWCEN(3) = LOWCEN(3)
C if doing capsule option then the second centre must also be set
            NEWLVC(1) = LOWLVC(1)
            NEWLVC(2) = LOWLVC(2)
            NEWLVC(3) = LOWLVC(3)

C the 'energy' is initially high
C so that first point is guaranteed to be accepted
            CURENG = 1D20
            LOWENG = 1D20
C temperature starts at MCKTIN
            MCKT = MCKTIN
      	    NREJ = 0
C for spherebox option then the long vector starts randomly
            IF (LSPHBX) THEN
              LOWLVC(1) = 0.
              LOWLVC(2) = 0.
              LOWLVC(3) = 0.
            ENDIF
          ELSE
C 27/05/94 put finding new point NEWCEN on the plane through
C CURCEN defined by channel vector CVECT with a maximum
C displacement from CURCEN of MCLEN into s/r HONEWP
            CALL HONEWP( NEWCEN, CURCEN, CVECT, MCLEN)
C find second random new point - put into newlvc
            IF (LCAPS) CALL HONEWP( NEWLVC, CURLVC, CVECT, MCLEN)
      	  ENDIF

C if we are doing the spherebox option we also need a new
C long vector NEWLVC N.B. this must be orthogonal to cvect
C and is biased towards LOWLVC (the vector foun on previous step)
          IF (LSPHBX) THEN
            CALL HONEWV( NEWLVC, LOWLVC, CVECT)
C 17/6/94 - spherebox option.
C Fit spherebox with the largest are normal to cvect onto point
C NEWENG is minus the 'radius' of the spherebox -
C that is minus the root of the area divided by pi
            CALL HSBXEN( NEWCEN, NEWENG, IAT1, IAT2, DAT2,
     &        ATMAX, ATNO, ATXYZ, ATVDW,
     &        ATRAD2, CVECT, NEWLVC, NEWLBO, NEWSBO, NEWBRD,
     &        NOUT, LERR, PI)
            IF (LERR) THEN
              WRITE( NOUT, *) 'ERROR has been found on call to '
              WRITE( NOUT, *) '  HSBXEN from HOLE (1)'
              WRITE( NOUT, *) '  Aborting ***********'
              GOTO 55555
            ENDIF
C or are we doing the capsule option?
          ELSEIF (LCAPS) THEN
            CALL HCAPEN( NEWCEN, NEWENG, NEWLVC, NEWBRD,
     &		 IAT1, IAT2, DAT2,
     &           ATMAX, ATNO, ATXYZ, ATVDW, PI)
           if (ldbug) then
	     write( nout, *) 'call to hcapen icount= ', icount
	     write( nout, *) 'newcen=', newcen
	     write( nout, *) 'newlvc=', newlvc
             write( nout, *) 'neweng= ',neweng
           endif
          ELSE
C NOT doing spherebox or capsule option
C find energy of point newcen
C - energy is minus radius the largest sphere
C which can be centered at this point without vdW overlap
C iat1 and iat2 are the atom numbers of the nearest two atoms
C to the centre and DAT2 is the distance - vdw  radius for the 2nd atom
            CALL HOLEEN( NEWCEN, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &           ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)

          ENDIF

C lowest energy found?
          IF ( NEWENG .LT. LOWENG ) THEN
      	    LOWSTP    = ICOUNT
            LOWENG    = NEWENG
      	    LOWCEN(1) = NEWCEN(1)
      	    LOWCEN(2) = NEWCEN(2)
      	    LOWCEN(3) = NEWCEN(3)
            if (ldbug) write(nout,*) 'debug lowest energy'
C if doing spherebox then have to store long vector,
C boxdim's & sphere radius.
            IF (LSPHBX) THEN
              LOWLVC(1) = NEWLVC(1)
              LOWLVC(2) = NEWLVC(2)
              LOWLVC(3) = NEWLVC(3)
              LOWLBO    = NEWLBO
              LOWSBO    = NEWSBO
              LOWBRD    = NEWBRD
            ELSEIF (LCAPS) THEN
C capsule -store second point
              LOWLVC(1) = NEWLVC(1)
              LOWLVC(2) = NEWLVC(2)
              LOWLVC(3) = NEWLVC(3)
            ENDIF

      	  ENDIF

C accept this point?
      	  HGOOD = NEWENG - CURENG
C energy down?
          IF (HGOOD.LT.0.0) THEN
C accept
      	    CURSTP    = ICOUNT
            CURENG    = NEWENG
      	    CURCEN(1) = NEWCEN(1)
      	    CURCEN(2) = NEWCEN(2)
      	    CURCEN(3) = NEWCEN(3)

C if doing spherebox then have to store long vector,
C boxdim's & sphere radius.
            IF (LSPHBX) THEN
              CURLVC(1) = NEWLVC(1)
              CURLVC(2) = NEWLVC(2)
              CURLVC(3) = NEWLVC(3)
              CURLBO    = NEWLBO
              CURSBO    = NEWSBO
              CURBRD    = NEWBRD
            ELSEIF (LCAPS) THEN
C capsule -store second point
              CURLVC(1) = NEWLVC(1)
              CURLVC(2) = NEWLVC(2)
              CURLVC(3) = NEWLVC(3)
            ENDIF

C debug output
	   if (ldbug) then
              write(nout,*) 'debug accept lower   step', icount
              write(nout,*)'newcen ',real(newcen(1)),real(newcen(2)),
     &				     real(newcen(3))
              write(nout,*)'cureng ', real(cureng)
              write(nout,*)'loweng ', real(loweng)
              write(nout,*)'at1 '//atbrk(iat1),atrno(iat1),-real(neweng)
              write(nout,*)'at2 '//atbrk(iat2),atrno(iat2), real(dat2)
              write(nout,*)'mckt ', real(mckt)
              if (lsphbx) then
                write(nout,*) 'newlvc ', newlvc
                write(nout,*) 'newlbo ', newlbo
                write(nout,*) 'newsbo ', newsbo
                write(nout,*) 'newbrd ', newbrd
              endif
      	      write(nout,*)
            endif

          ELSE
C accept according to a random number
            IF (MCKT.GT.0) THEN
C probablity that this will be accepted
      	      PROB = EXP(-HGOOD/MCKT)
C find random number between 0 and 1
      	      CALL DRAND( RANDYN)
      	      IF (RANDYN.LT.PROB) THEN
C accept
      	        CURSTP    = ICOUNT
                CURENG    = NEWENG
      	        CURCEN(1) = NEWCEN(1)
       	        CURCEN(2) = NEWCEN(2)
      	        CURCEN(3) = NEWCEN(3)
C if doing spherebox then have to store long vector,
C boxdim's & sphere radius.
                IF (LSPHBX) THEN
                  CURLVC(1) = NEWLVC(1)
                  CURLVC(2) = NEWLVC(2)
                  CURLVC(3) = NEWLVC(3)
                  CURLBO    = NEWLBO
                  CURSBO    = NEWSBO
                  CURBRD    = NEWBRD
                ELSEIF (LCAPS) THEN
C capsule -store second point
                  CURLVC(1) = NEWLVC(1)
                  CURLVC(2) = NEWLVC(2)
                  CURLVC(3) = NEWLVC(3)
                ENDIF

            if (ldbug) then
              write(nout,*) 'debug accept due to prob step', icount
              write(nout,*) 'prob rand', real(prob), real(randyn)
              write(nout,*)'newcen ',real(newcen(1)),real(newcen(2)),
     &				     real(newcen(3))
              write(nout,*)'cureng ', real(cureng)
              write(nout,*)'loweng ', real(loweng)
            write(nout,*)'at1 '//atbrk(iat1),atrno(iat1),-real(neweng)
            write(nout,*)'at2 '//atbrk(iat2),atrno(iat2), real(dat2)
              write(nout,*)'mckt ', real(mckt)
              if (lsphbx) then
                write(nout,*) 'newlvc ', newlvc
                write(nout,*) 'newlbo ', newlbo
                write(nout,*) 'newsbo ', newsbo
                write(nout,*) 'newbrd ', newbrd
              endif
      	      write(nout,*)
            endif

C reject due to prob
              ELSE
      		NREJ = NREJ + 1
              ENDIF
C reject as temperature is zero
            ELSE
      	      NREJ = NREJ + 1
            ENDIF
          ENDIF

C step the temperature down - down to zero at 9/10's of the step
          MCKT = MCKT - MCKTIN/(0.9*REAL(MCSTEP))
      	  IF (MCKT.LT.0) MCKT = 0.0

C finished MCSTEPS
20      CONTINUE

C 21/6/94 - problem when doing spherebox option
C is that degree of refinement due to Monte Carlo
C is insufficient so further refine lowest energy solution
C using conventional minimization.
        IF (LSPHBX) THEN
C tell user results before minimization
          IF (SHORTO.LT.1) WRITE( NOUT, '(A/ A,F8.4, 3(/A,3F8.3) )')
     &' Applying sd min to lowest energy position found.',
     &' Before min - energy (effective radius)= ', LOWENG,
     &' Centre= ', LOWCEN,
     &' Long vector= ', LOWLVC,
     &' long box length, short box length, box radius ',
     &  LOWLBO, LOWSBO, LOWBRD
          CALL HSBXMI( LOWCEN, LOWENG, IAT1, IAT2, DAT2,
     &        ATMAX, ATNO, ATXYZ, ATVDW,
     &        ATRAD2, CVECT, LOWLVC, LOWLBO, LOWSBO, LOWBRD,
     &        NOUT, LERR, PI, NOSTEP, ENDRAD)
          IF (LERR) THEN
            WRITE( NOUT, *) 'ERROR has been found on call to '
            WRITE( NOUT, *) '  HSBXMI from HOLE (1)'
            WRITE( NOUT, *) '  Aborting ***********'
            GOTO 55555
          ENDIF
        ENDIF

C tell user lowest energy point = highest radius
C first find closest atoms
C if doing capsule use special option
        IF (LCAPS) THEN
          CALL HCAPEN( LOWCEN, NEWENG, LOWLVC, LOWBRD, IAT1, IAT2, DAT2,
     &           ATMAX, ATNO, ATXYZ, ATVDW, PI)
        ELSE
          CALL HOLEEN( LOWCEN, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &         ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
        ENDIF
        IF (SHORTO.LT.1) WRITE(NOUT,'(A, /A,3F8.3,
     &        2(/A,F8.3,3X,A4,A3,1X,A1,I5) /A,I5)' )
     & ' highest radius point found:',
     & '  at point ', LOWCEN,
     & '  closest atom surface ', -LOWENG,
     &     ATBRK(IAT1), ATRES(IAT1), ATCHN(IAT1), ATRNO(IAT1),
     & '  2nd closest surface  ', DAT2,
     &     ATBRK(IAT2), ATRES(IAT2), ATCHN(IAT2), ATRNO(IAT2),
     & '  found on step', LOWSTP
C tell user current point if different
        IF (CURENG.EQ.LOWENG) THEN
      	  IF (SHORTO.LT.1) write(nout,*) ' this is also current point'
        ELSE
          IF (LCAPS) THEN
            CALL HCAPEN( CURCEN, NEWENG, CURLVC, NEWBRD,
     &		         IAT1, IAT2, DAT2, ATMAX, ATNO, ATXYZ, ATVDW, PI)
          ELSE
            CALL HOLEEN( CURCEN, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &         ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
          ENDIF
          IF (SHORTO.LT.1) WRITE(NOUT,'(A, /A,3F8.3,
     &       2(/A,F8.3,3X,A4,A3,1X,A1,I5) /A,I5)' )
     & ' current point:',
     & '  at point ', CURCEN,
     & '  closest atom surface ', -CURENG,
     &     ATBRK(IAT1), ATRES(IAT1), ATCHN(IAT1), ATRNO(IAT1),
     & '  2nd closest surface  ', DAT2,
     &     ATBRK(IAT2), ATRES(IAT2), ATCHN(IAT2), ATRNO(IAT2),
     & '  found on step', CURSTP
        ENDIF

        IF (LSPHBX) THEN
C tell user extra bits of info for spherebox
          IF (SHORTO.LT.1) WRITE( NOUT, '(A,I5, 2(/ A,3F8.3) )')
     &' Number of steps of sd applied ', NOSTEP,
     &' Long vector= ', LOWLVC,
     &' long box length, short box length, box radius ',
     &  LOWLBO, LOWSBO, LOWBRD

        ELSEIF (LCAPS) THEN
C tell user extra bits of info for capsule option
          IF (SHORTO.LT.1) WRITE( NOUT, '(A,3F8.3/ A,F8.3/ A,F8.3/ A)')
     &' Capsule option - second centre ', LOWLVC,
     &'                  distance between centres ',
     &     SQRT( (LOWCEN(1)-LOWLVC(1))**2 +
     &           (LOWCEN(2)-LOWLVC(2))**2 +
     &           (LOWCEN(3)-LOWLVC(3))**2 ),
     &' Capsule radius of lowest point ', LOWBRD,
     &'              (other radii quoted are effective)'
        ENDIF

C tell user no of rejected points
        IF (SHORTO.LT.1) WRITE(NOUT,*) ' no. of rejections ', NREJ

C have we reached the end of the channel?
C - if so radius will be high
C 22/11/93 - allow user to specify the radius at which the
C end of channel is found as ENDRAD
        IF (-LOWENG.LT.ENDRAD) THEN

	  IF (SAMPLE.GT.0) THEN
C have one more centre intial point goes to
C zero as strnop starts at -1
	    STRNOP = STRNOP + 1
	    IF (STRNOP.GT.STRMAX) THEN
	      WRITE(NOUT,*) 'ERROR'
	      WRITE(NOUT,*) 'array bound STRMAX exceeded'
	      WRITE(NOUT,*) 'increase from: ', STRMAX
	      GOTO 55555
	    ENDIF
C store the point in +ve part of the array
	    STRCEN(1,STRNOP) = LOWCEN(1)
	    STRCEN(2,STRNOP) = LOWCEN(2)
	    STRCEN(3,STRNOP) = LOWCEN(3)
	    STRRAD(STRNOP) =  -LOWENG
C store the sphere-box data
	    STRLVC(1,STRNOP) = LOWLVC(1)
	    STRLVC(2,STRNOP) = LOWLVC(2)
	    STRLVC(3,STRNOP) = LOWLVC(3)
	    STRLBO(STRNOP) =   LOWLBO
	    STRSBO(STRNOP) =   LOWSBO
	    STRBRD(STRNOP) =   LOWBRD
            IF (SHORTO.LT.1)
     &        WRITE(NOUT, '(A,I5/)') ' stored as ', STRNOP
	  ELSE
C -ve
	    STRNON = STRNON + 1
	    IF (STRNON.GT.STRMAX) THEN
	      WRITE(NOUT,*) 'ERROR'
	      WRITE(NOUT,*) 'array bound STRMAX exceeded'
	      WRITE(NOUT,*) 'increase from: ', STRMAX
	      GOTO 55555
	    ENDIF
C store the point in -ve part of the array
	    STRCEN(1,-STRNON) = LOWCEN(1)
	    STRCEN(2,-STRNON) = LOWCEN(2)
	    STRCEN(3,-STRNON) = LOWCEN(3)
	    STRRAD(-STRNON) =  -LOWENG
C store the sphere-box data
            STRLVC(1,-STRNON) = LOWLVC(1)
            STRLVC(2,-STRNON) = LOWLVC(2)
            STRLVC(3,-STRNON) = LOWLVC(3)
            STRLBO(-STRNON) =   LOWLBO
            STRSBO(-STRNON) =   LOWSBO
            STRBRD(-STRNON) =   LOWBRD
            IF (SHORTO.LT.1)
     &        WRITE(NOUT, '(A,I5/)') ' stored as ',  -STRNON
	  ENDIF

C 18/07/94 output sphpdb file as we go along
          IF (FPDBSP.NE.'NONE') THEN
C is this a +ve or negative record?
            IF (SAMPLE.GT.0) THEN
              IREC = STRNOP
            ELSE
              IREC = -STRNON
            ENDIF
C 24/10/95 split writing sphpdb file into seperate subroutine
! 24/11/00 do not write the record if doing connolly
! do in concal instead
            IF (CONNR(1).LE.0)
     &                   CALL WPDBSP( SPDBSP, LCAPS, LSPHBX, IREC,
     &                   STRMAX, STRCEN, STRRAD,
     &		         STRLVC, STRLBO, STRSBO, STRBRD, CVECT, ENDRAD)
          ENDIF

C Do connolly calculation after storage
          IF (CONNR(1).GT.0) THEN
C connolly routine returns requiv
            CALL CONCAL( NIN, NOUT, LERR,
     &			 CVECT, LOWCEN,
     &			 ATMAX, ATNO, ATBRK, ATRES, ATCHN, ATRNO,
     &			 ATXYZ, ATVDW, ATBND,
     &                   SPDBSP, FPDBSP,
     &			 SHORTO,
     &			 ENDRAD, CUTSIZE, CONNR, PERPVE, PERPVN, REQUIV,
     &			 PEG_WRITEALL, IREC, SAMPLE)
C store requiv - in strbrd as this array is not used if connolly routine in
C use - can tell by sample where to put
	    IF (SAMPLE.GT.0) THEN
	      STRBRD(STRNOP) = REQUIV
              IF (SHORTO.LT.1) WRITE(NOUT, '(A,I5/ A/A/)')
     &' Requiv stored for ', STRNOP,
     &' -----',
     &' '

	    ELSE
C -ve
              STRBRD(-STRNON) = REQUIV
              IF (SHORTO.LT.1) WRITE(NOUT, '(A,I5/ A/A/)')
     &' Requiv stored for ', -STRNON,
     &' -----',
     &' '
	    ENDIF

          ENDIF

C store the centre
C +ve or -ve?
C are we doing graphics and drawing close contact lines?
C only do if the radius found is +ve
C draw the lines connecting the closest atoms to the surface
	  IF ((FHYDRA(1:4).NE.'NONE') .AND.
     &	      LLINE .AND. (LOWENG.LT.0.)     ) THEN
C first find closest atoms
	    CALL HOLEEN( LOWCEN, NEWENG, IAT1, IAT2, IAT3, DAT2, DAT3,
     &			 ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)

C draw line from iat1 towards lowcen distance vdw radius of the atom
	    CALL HOLLIN( SHYDRA, LOWCEN, IAT1, ATMAX, ATXYZ, ATVDW)
C repeat for iat2
	    CALL HOLLIN( SHYDRA, LOWCEN, IAT2, ATMAX, ATXYZ, ATVDW)
	  ENDIF

C move lowcen by distance sample angs
C in direction cvect (which is a unit vector)
      	  LOWCEN(1) = LOWCEN(1) + SAMPLE*CVECT(1)
      	  LOWCEN(2) = LOWCEN(2) + SAMPLE*CVECT(2)
      	  LOWCEN(3) = LOWCEN(3) + SAMPLE*CVECT(3)
C if we are doing capsule option also have to move the second point
          IF (LCAPS) THEN
            LOWLVC(1) = LOWLVC(1) + SAMPLE*CVECT(1)
            LOWLVC(2) = LOWLVC(2) + SAMPLE*CVECT(2)
            LOWLVC(3) = LOWLVC(3) + SAMPLE*CVECT(3)
C 27/5/96 had changed routine so that started capsule
C at single point rather than moved both ends along
C but this produces very much less stable routine -
C get best of both worlds with a test as to which option is
C the better.
C Put how go this is into LOWENG
            CALL HCAPEN( LOWCEN, LOWENG, LOWLVC, NEWBRD,
     &		         IAT1, IAT2, DAT2, ATMAX, ATNO, ATXYZ, ATVDW, PI)
C 23/11/95
C problem with using moved on capsule ends in hole - sometimes
C capsule gets too long! - so try making new capsule start
C at single point 27/5/96 - putinto CUR store rather than low
            CURLVC(1) = 0.5*(LOWLVC(1)+LOWCEN(1))
            CURLVC(2) = 0.5*(LOWLVC(2)+LOWCEN(2))
            CURLVC(3) = 0.5*(LOWLVC(3)+LOWCEN(3))
            CURCEN(1) = CURLVC(1)
            CURCEN(2) = CURLVC(2)
            CURCEN(3) = CURLVC(3)
C now work out how go this is
            CALL HCAPEN( CURCEN, CURENG, CURLVC, NEWBRD,
     &		         IAT1, IAT2, DAT2, ATMAX, ATNO, ATXYZ, ATVDW, PI)
C as energy is minus the effective radius the largest sphere
            IF (CURENG.LT.2.*LOWENG) THEN
C midpoint is better than moved on capsule
C so replace
              LOWLVC(1) = CURLVC(1)
              LOWLVC(2) = CURLVC(2)
              LOWLVC(3) = CURLVC(3)
              LOWCEN(1) = CURCEN(1)
              LOWCEN(2) = CURCEN(2)
              LOWCEN(3) = CURCEN(3)
              WRITE( NOUT, '(A/A/ 2(A,F12.3)/ A/ A,3F12.3)')
     &' CAPSULE OPTION WARNING***',
     &'   Trying to move on current capsule by adding SAMPLE',
     &'   But eff radius=', -LOWENG, ' Compared to mid-point=', -CURENG,
     &'   (replace only if mid-point twice as good)',
     &'   So using midpoint coords= ', LOWCEN
              WRITE( NOUT, '(A)')
     &'   In plain english:',
     &'   The channel may be changing shape drastically at this point',
     &'   and the routine may be becoming stuck in a side passage.',
     &'   You are advised to look what is happening using molecular',
     &'   graphics (see section 6.2 of HOLE documentation',
     &'   (thanks to Peter Tieleman for suggesting clarification).',
     &' CAPSULE OPTION WARNING*** (end)'
            ENDIF

          ENDIF
C work out new point
C END OF DO UNTIL
          GOTO 10
        ENDIF

C tell user that we have an end
	IF (SHORTO.LT.1) WRITE( NOUT,'(A,F6.1,A)')
     &' This is an end! (radius above', ENDRAD, ' angs)'

C record the fact that previous record should be regarded as
C an "end record" in .sph output file (if we are producing this)
C        IF (FPDBSP.NE.'NONE') WRITE( SPDBSP, '(A)') 'LAST-REC-END'
C 8/1/00 this is not sufficient - generate an array of
C last-rec-end records - do this s/r addend
	IF (FPDBSP.NE.'NONE') THEN

! list is now done in s/r wpdbsp
!          WRITE( SPDBSP, '(A)') 'LAST-REC-END'
C move back to the last accepted point
C infact use the one before as the last is sometimes wonky!
          IF (SAMPLE.GT.0D0) THEN
C At +ve end
	    LOWCEN(1) = STRCEN(1,STRNOP-1)
	    LOWCEN(2) = STRCEN(2,STRNOP-1)
	    LOWCEN(3) = STRCEN(3,STRNOP-1)
          ELSE
C At -ve end
	    LOWCEN(1) = STRCEN(1,-STRNON+1)
	    LOWCEN(2) = STRCEN(2,-STRNON+1)
	    LOWCEN(3) = STRCEN(3,-STRNON+1)
	  ENDIF
C s/r to add the records
	  CALL ADDEND( SPDBSP, LOWCEN, SAMPLE, ENDRAD,
     &		       CVECT, PERPVE, PERPVN,
     &                 ATMAX, ATNO, ATXYZ, ATVDW, CUTSIZE)
        ENDIF

C have we looked down from the initial point?
	IF (SAMPLE.GT.0D0) THEN
C change direction
	  SAMPLE = -SAMPLE
C back to original point
	  LOWCEN(1) = STRCEN(1,0) + SAMPLE*CVECT(1)
	  LOWCEN(2) = STRCEN(2,0) + SAMPLE*CVECT(2)
	  LOWCEN(3) = STRCEN(3,0) + SAMPLE*CVECT(3)
C if doing capsule option must also reset the second centre
          IF (LCAPS) THEN
            LOWLVC(1) = STRLVC(1,0) + SAMPLE*CVECT(1)
            LOWLVC(2) = STRLVC(2,0) + SAMPLE*CVECT(2)
            LOWLVC(3) = STRLVC(3,0) + SAMPLE*CVECT(3)
          ENDIF
C to have continuous centre line need to now write the zeroth
C sphere record to the sphere centre pdb file
          IF (FPDBSP.NE.'NONE')
     &      CALL WPDBSP( SPDBSP, LCAPS, LSPHBX, 0,
     &                   STRMAX, STRCEN, STRRAD,
     &                   STRLVC, STRLBO, STRSBO, STRBRD, CVECT, ENDRAD)

C carry on
	  GOTO 10
	ENDIF

C 15/11/95 split off HOLE calculation into seperate s/r
C Now Calculation is finished can output results (graphical and numerical)
55555 CONTINUE
      RETURN
      END


C****
C                    ************************
C                    *     OASIS MODULE     *
C                    *     ------------     *
C                    ************************
C****
C***********************************************************************
C     This module belongs to the SCRIP library. It is modified to run
C     within OASIS.
C     Modifications:
C       - routine does not read SCRIP grid description files, but gets
C         arrays from the calling routine
C       - unit conversion : only from degrees (OASIS unit) to radians
C       - some allocated array will be freed in the end to allow multiple
C         calls of SCRIP
C       - map-methods and restriction-types are written in capital letters
C       - added bin definition for reduced grid
C
C     Modified by            V. Gayler,  M&D                  20.09.2001
C     Modified by            D. Declat,  CERFACS              27.06.2002
C***********************************************************************
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!     This module reads in and initializes two grids for remapping.
!     NOTE: grid1 must be the master grid -- the grid that determines
!           which cells participate (e.g. land mask) and the fractional
!           area of grid2 cells that participate in the remapping.
!
!-----------------------------------------------------------------------
!
!     CVS:$Id: grids.f 2826 2010-12-10 11:14:21Z valcke $
!
!     Copyright (c) 1997, 1998 the Regents of the University of
!       California.
!
!     This software and ancillary information (herein called software)
!     called SCRIP is made available under the terms described here.
!     The software has been approved for release with associated
!     LA-CC Number 98-45.
!
!     Unless otherwise indicated, this software has been authored
!     by an employee or employees of the University of California,
!     operator of the Los Alamos National Laboratory under Contract
!     No. W-7405-ENG-36 with the U.S. Department of Energy.  The U.S.
!     Government has rights to use, reproduce, and distribute this
!     software.  The public may copy and use this software without
!     charge, provided that this Notice and any statement of authorship
!     are reproduced on all copies.  Neither the Government nor the
!     University makes any warranty, express or implied, or assumes
!     any liability or responsibility for the use of this software.
!
!     If software is modified to produce derivative works, such modified
!     software should be clearly marked, so as not to confuse it with
!     the version available from Los Alamos National Laboratory.
!
!***********************************************************************

      module grids

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

      use kinds_mod    ! defines data types
      use constants    ! common constants
      use iounits      ! I/O unit manager
      USE mod_oasis_flush

      implicit none

!-----------------------------------------------------------------------
!
!     variables that describe each grid
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), save ::
     &             grid1_size, grid2_size, ! total points on each grid
     &             grid1_rank, grid2_rank, ! rank of each grid
     &             grid1_corners, grid2_corners ! number of corners
                                                ! for each grid cell

      integer (kind=int_kind), dimension(:), allocatable, save ::
     &             grid1_dims, grid2_dims  ! size of each grid dimension

      character(char_len), save ::
     &             grid1_name, grid2_name  ! name for each grid

      character (char_len), save ::
     &             grid1_units, ! units for grid coords (degs/radians)
     &             grid2_units  ! units for grid coords

      real (kind=dbl_kind), parameter ::
     &      deg2rad = pi/180.   ! conversion for deg to rads

!-----------------------------------------------------------------------
!
!     grid coordinates and masks
!
!-----------------------------------------------------------------------

      logical (kind=log_kind), dimension(:), allocatable, save ::
     &             grid1_mask,        ! flag which cells participate
     &             grid2_mask         ! flag which cells participate

      real (kind=dbl_kind), dimension(:), allocatable, save ::
     &             grid1_center_lat,  ! lat/lon coordinates for
     &             grid1_center_lon,  ! each grid center in radians
     &             grid2_center_lat,
     &             grid2_center_lon,
     &             grid1_area,        ! tot area of each grid1 cell
     &             grid2_area,        ! tot area of each grid2 cell
     &             grid1_area_in,     ! area of grid1 cell from file
     &             grid2_area_in,     ! area of grid2 cell from file
     &             grid1_frac,        ! fractional area of grid cells
     &             grid2_frac         ! participating in remapping

      real (kind=dbl_kind), dimension(:,:), allocatable, save ::
     &             grid1_corner_lat,  ! lat/lon coordinates for
     &             grid1_corner_lon,  ! each grid corner in radians
     &             grid2_corner_lat,
     &             grid2_corner_lon

      logical (kind=log_kind), save ::
     &             luse_grid_centers ! use centers for bounding boxes
     &,            luse_grid1_area   ! use area from grid file
     &,            luse_grid2_area   ! use area from grid file

      real (kind=dbl_kind), dimension(:,:), allocatable, save ::
     &             grid1_bound_box,  ! lat/lon bounding box for use
     &             grid2_bound_box   ! in restricting grid searches

!-----------------------------------------------------------------------
!
!     bins for restricting searches
!
!-----------------------------------------------------------------------

      character (char_len), save ::
     &        restrict_type  ! type of bins to use

      integer (kind=int_kind), save ::
     &        num_srch_bins,  ! num of bins for restricted srch
     &        num_srch_red    ! num of bins for reduced case

      integer (kind=int_kind), dimension(:,:), allocatable, save ::
     &        bin_addr1, ! min,max adds for grid1 cells in this lat bin
     &        bin_addr2  ! min,max adds for grid2 cells in this lat bin
      integer (kind=int_kind), dimension(:,:), allocatable, save ::
     &        bin_addr1_r  ! min,max adds for red grid1 cells

      real(kind=dbl_kind), dimension(:,:), allocatable, save ::
     &        bin_lats   ! min,max latitude for each search bin
     &,       bin_lons   ! min,max longitude for each search bin
      real(kind=dbl_kind), dimension(:,:), allocatable, save ::
     &        bin_lats_r ! min,max lat for each search bin for red grid
     &,       bin_lons_r ! min,max lon for each search bin for red grid

!***********************************************************************

      contains

!***********************************************************************

      subroutine grid_init(m_method, rst_type, n_srch_bins,
     $                     src_size, dst_size, src_dims, dst_dims,
     &                     src_rank, dst_rank, ncrn_src, ncrn_dst,
     &                     src_mask, dst_mask, src_name, dst_name,
     &                     src_lat,  src_lon,  dst_lat,  dst_lon,
     &                     src_corner_lat, src_corner_lon,
     &                     dst_corner_lat, dst_corner_lon,
     &                     logunit)

!-----------------------------------------------------------------------
!
!     this routine gets grid info from routine scriprmp and makes any
!     necessary changes (e.g. for 0,2pi longitude range)
!
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), intent(in) ::
     &     n_srch_bins,         ! num of bins for restricted srch
     &     src_size,            ! source grid size
     &     dst_size,            ! target grid size
     &     src_rank,            ! source grid rank
     &     dst_rank,            ! target grid rank
     &     src_dims(src_rank),  ! source grid dimensions
     &     dst_dims(dst_rank),  ! target grid dimensions
     &     ncrn_src,            ! number of corners of a source grid cell
     &     ncrn_dst,            ! number of corners of a target grid cell
     &     src_mask(src_size),  ! source grid mask (master mask)
     &     dst_mask(dst_size)   ! target grid mask

      integer(kind=int_kind), intent(in), optional ::
     &     logunit

      character*8, intent(in) ::
     &     m_method,            ! remapping method
     &     rst_type,            ! restriction type
     &     src_name,            ! source grid name
     &     dst_name             ! target grid name

      real (kind=real_kind), intent (in) ::
     &     src_lat(src_size), ! source grid latitudes
     &     src_lon(src_size), ! sourde grid longitudes
     &     dst_lat(dst_size),   ! target grid latitudes
     &     dst_lon(dst_size),   ! target grid longitudes
     &     src_corner_lat(ncrn_src,src_size),
     &     src_corner_lon(ncrn_src,src_size),
     &     dst_corner_lat(ncrn_dst,dst_size),
     &     dst_corner_lon(ncrn_dst,dst_size)

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind) ::
     &  n      ! loop counter
     &, nele   ! element loop counter
     &, i,j    ! logical 2d addresses
     &, ip1,jp1
     &, n_add, e_add, ne_add
     &, nx, ny

      real (kind=dbl_kind) ::
     &  dlat, dlon          ! lat/lon intervals for search bins

      real (kind=dbl_kind), dimension(4) ::
     &  tmp_lats, tmp_lons  ! temps for computing bounding boxes
      character(len=*),parameter :: subname = 'scrip:grid_init '
!
!-----------------------------------------------------------------------
!
      if (present(logunit)) then
         nulou = logunit
      endif

      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Entering routine grid_init'
         WRITE (UNIT = nulou,FMT = *)' '
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
!-----------------------------------------------------------------------
!
!     allocate grid coordinates/masks and read data
!
!-----------------------------------------------------------------------

!      write(nulou,*) subname,trim(m_method)
!      write(nulou,*) subname,src_size,dst_size,src_rank,dst_rank

      select case(m_method)
      case ('CONSERV')
        luse_grid_centers = .false.
      case ('BILINEAR')
        luse_grid_centers = .true.
      case ('BICUBIC')
        luse_grid_centers = .true.
      case ('DISTWGT')
        luse_grid_centers = .true.
      case ('GAUSWGT')
        luse_grid_centers = .true.
      case default
        stop 'unknown mapping method'
      end select

      allocate( grid1_mask      (src_size),
     &          grid2_mask      (dst_size),
     &          grid1_center_lat(src_size),
     &          grid1_center_lon(src_size),
     &          grid2_center_lat(dst_size),
     &          grid2_center_lon(dst_size),
     &          grid1_area      (src_size),
     &          grid2_area      (dst_size),
     &          grid1_frac      (src_size),
     &          grid2_frac      (dst_size),
     &          grid1_dims      (src_rank),
     &          grid2_dims      (dst_rank),
     &          grid1_bound_box (4       , src_size),
     &          grid2_bound_box (4       , dst_size))

      if (.not. luse_grid_centers) then
        allocate( grid1_corner_lat(ncrn_src, src_size),
     &            grid1_corner_lon(ncrn_src, src_size),
     &            grid2_corner_lat(ncrn_dst, dst_size),
     &            grid2_corner_lon(ncrn_dst, dst_size))
      endif

!-----------------------------------------------------------------------
!
!     copy input data to module data
!
!-----------------------------------------------------------------------

      restrict_type    = rst_type
      num_srch_bins    = n_srch_bins
      grid1_size       = src_size
      grid2_size       = dst_size
      grid1_dims       = src_dims
      grid2_dims       = dst_dims
      grid1_rank       = src_rank
      grid2_rank       = dst_rank
      grid1_corners    = ncrn_src
      grid2_corners    = ncrn_dst
      grid1_name       = src_name
      grid2_name       = dst_name
      grid1_center_lat = src_lat
      grid1_center_lon = src_lon
      grid2_center_lat = dst_lat
      grid2_center_lon = dst_lon

      if (.not. luse_grid_centers) then
        grid1_corner_lat = src_corner_lat
        grid1_corner_lon = src_corner_lon
        grid2_corner_lat = dst_corner_lat
        grid2_corner_lon = dst_corner_lon
      endif

c      if (luse_grid1_area) then
c        grid1_area_in
c      endif
c      if (luse_grid2_area) then
c        grid2_area_in
c      endif

      grid1_area = zero
      grid1_frac = zero
      grid2_area = zero
      grid2_frac = zero

!-----------------------------------------------------------------------
!
!     initialize logical mask and convert lat/lon units if required
!
!-----------------------------------------------------------------------
      where (src_mask == 1)
        grid1_mask = .true.
      elsewhere
        grid1_mask = .false.
      endwhere

      where (dst_mask == 1)
        grid2_mask = .true.
      elsewhere
        grid2_mask = .false.
      endwhere

C
C* -- convert unit from degrees (OASIS unit) to radians
C
      grid1_center_lat = grid1_center_lat*deg2rad
      grid1_center_lon = grid1_center_lon*deg2rad
      grid2_center_lat = grid2_center_lat*deg2rad
      grid2_center_lon = grid2_center_lon*deg2rad

      if (.not. luse_grid_centers) then
        grid1_corner_lat = grid1_corner_lat*deg2rad
        grid1_corner_lon = grid1_corner_lon*deg2rad
        grid2_corner_lat = grid2_corner_lat*deg2rad
        grid2_corner_lon = grid2_corner_lon*deg2rad
      endif

      grid1_units='radians'
      grid2_units='radians'
!-----------------------------------------------------------------------
!
!     convert longitudes to 0,2pi interval
!
!-----------------------------------------------------------------------

      where (grid1_center_lon .gt. pi2)  grid1_center_lon =
     &                                   grid1_center_lon - pi2
      where (grid1_center_lon .lt. zero) grid1_center_lon =
     &                                   grid1_center_lon + pi2
      where (grid2_center_lon .gt. pi2)  grid2_center_lon =
     &                                   grid2_center_lon - pi2
      where (grid2_center_lon .lt. zero) grid2_center_lon =
     &                                   grid2_center_lon + pi2

      if (.not. luse_grid_centers) then
        where (grid1_corner_lon .gt. pi2)  grid1_corner_lon =
     &                                     grid1_corner_lon - pi2
        where (grid1_corner_lon .lt. zero) grid1_corner_lon =
     &                                     grid1_corner_lon + pi2
        where (grid2_corner_lon .gt. pi2)  grid2_corner_lon =
     &                                     grid2_corner_lon - pi2
        where (grid2_corner_lon .lt. zero) grid2_corner_lon =
     &                                     grid2_corner_lon + pi2
      endif
!-----------------------------------------------------------------------
!
!     make sure input latitude range is within the machine values
!     for +/- pi/2
!
!-----------------------------------------------------------------------

      where (grid1_center_lat >  pih) grid1_center_lat =  pih
      where (grid1_center_lat < -pih) grid1_center_lat = -pih
      where (grid2_center_lat >  pih) grid2_center_lat =  pih
      where (grid2_center_lat < -pih) grid2_center_lat = -pih

      if (.not. luse_grid_centers) then
        where (grid1_corner_lat >  pih) grid1_corner_lat =  pih
        where (grid1_corner_lat < -pih) grid1_corner_lat = -pih
        where (grid2_corner_lat >  pih) grid2_corner_lat =  pih
        where (grid2_corner_lat < -pih) grid2_corner_lat = -pih
      endif

!-----------------------------------------------------------------------
!
!     compute bounding boxes for restricting future grid searches
!
!-----------------------------------------------------------------------

      if (.not. luse_grid_centers) then

        grid1_bound_box(1,:) = minval(grid1_corner_lat, DIM=1)
        grid1_bound_box(2,:) = maxval(grid1_corner_lat, DIM=1)
        grid1_bound_box(3,:) = minval(grid1_corner_lon, DIM=1)
        grid1_bound_box(4,:) = maxval(grid1_corner_lon, DIM=1)

        grid2_bound_box(1,:) = minval(grid2_corner_lat, DIM=1)
        grid2_bound_box(2,:) = maxval(grid2_corner_lat, DIM=1)
        grid2_bound_box(3,:) = minval(grid2_corner_lon, DIM=1)
        grid2_bound_box(4,:) = maxval(grid2_corner_lon, DIM=1)
      else

        nx = grid1_dims(1)
        ny = grid1_dims(2)

        do n=1,grid1_size

          !*** find N,S and NE points to this grid point

          j = (n - 1)/nx +1
          i = n - (j-1)*nx

          if (i < nx) then
            ip1 = i + 1
          else
            !*** assume cyclic
            ip1 = 1
            !*** but if it is not, correct
            e_add = (j - 1)*nx + ip1
            if (abs(grid1_center_lat(e_add) -
     &              grid1_center_lat(n   )) > pih) then
              ip1 = i
            endif
          endif

          if (j < ny) then
            jp1 = j+1
          else
            !*** assume cyclic
            jp1 = 1
            !*** but if it is not, correct
            n_add = (jp1 - 1)*nx + i
            if (abs(grid1_center_lat(n_add) -
     &              grid1_center_lat(n   )) > pih) then
              jp1 = j
            endif
          endif

          n_add = (jp1 - 1)*nx + i
          e_add = (j - 1)*nx + ip1
          ne_add = (jp1 - 1)*nx + ip1

          !*** find N,S and NE lat/lon coords and check bounding box

          tmp_lats(1) = grid1_center_lat(n)
          tmp_lats(2) = grid1_center_lat(e_add)
          tmp_lats(3) = grid1_center_lat(ne_add)
          tmp_lats(4) = grid1_center_lat(n_add)

          tmp_lons(1) = grid1_center_lon(n)
          tmp_lons(2) = grid1_center_lon(e_add)
          tmp_lons(3) = grid1_center_lon(ne_add)
          tmp_lons(4) = grid1_center_lon(n_add)

          grid1_bound_box(1,n) = minval(tmp_lats)
          grid1_bound_box(2,n) = maxval(tmp_lats)
          grid1_bound_box(3,n) = minval(tmp_lons)
          grid1_bound_box(4,n) = maxval(tmp_lons)
        end do

        nx = grid2_dims(1)
        ny = grid2_dims(2)

        do n=1,grid2_size

          !*** find N,S and NE points to this grid point

          j = (n - 1)/nx +1
          i = n - (j-1)*nx

          if (i < nx) then
            ip1 = i + 1
          else
            !*** assume cyclic
            ip1 = 1
            !*** but if it is not, correct
            e_add = (j - 1)*nx + ip1
            if (abs(grid2_center_lat(e_add) -
     &              grid2_center_lat(n   )) > pih) then
              ip1 = i
            endif
          endif

          if (j < ny) then
            jp1 = j+1
          else
            !*** assume cyclic
            jp1 = 1
            !*** but if it is not, correct
            n_add = (jp1 - 1)*nx + i
            if (abs(grid2_center_lat(n_add) -
     &              grid2_center_lat(n   )) > pih) then
              jp1 = j
            endif
          endif

          n_add = (jp1 - 1)*nx + i
          e_add = (j - 1)*nx + ip1
          ne_add = (jp1 - 1)*nx + ip1

          !*** find N,S and NE lat/lon coords and check bounding box

          tmp_lats(1) = grid2_center_lat(n)
          tmp_lats(2) = grid2_center_lat(e_add)
          tmp_lats(3) = grid2_center_lat(ne_add)
          tmp_lats(4) = grid2_center_lat(n_add)

          tmp_lons(1) = grid2_center_lon(n)
          tmp_lons(2) = grid2_center_lon(e_add)
          tmp_lons(3) = grid2_center_lon(ne_add)
          tmp_lons(4) = grid2_center_lon(n_add)

          grid2_bound_box(1,n) = minval(tmp_lats)
          grid2_bound_box(2,n) = maxval(tmp_lats)
          grid2_bound_box(3,n) = minval(tmp_lons)
          grid2_bound_box(4,n) = maxval(tmp_lons)
        end do

      endif

      where (abs(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi)
        grid1_bound_box(3,:) = zero
        grid1_bound_box(4,:) = pi2
      end where

      where (abs(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi)
        grid2_bound_box(3,:) = zero
        grid2_bound_box(4,:) = pi2
      end where

      !***
      !*** try to check for cells that overlap poles
      !***

      where (grid1_center_lat > grid1_bound_box(2,:))
     &  grid1_bound_box(2,:) = pih

      where (grid1_center_lat < grid1_bound_box(1,:))
     &  grid1_bound_box(1,:) = -pih

      where (grid2_center_lat > grid2_bound_box(2,:))
     &  grid2_bound_box(2,:) = pih

      where (grid2_center_lat < grid2_bound_box(1,:))
     &  grid2_bound_box(1,:) = -pih

!-----------------------------------------------------------------------
!
!     set up and assign address ranges to search bins in order to
!     further restrict later searches
!
!-----------------------------------------------------------------------

      select case (restrict_type)

      case ('LATITUDE')
        write(nulou,*) 'Using latitude bins to restrict search.'

        allocate(bin_addr1(2,num_srch_bins))
        allocate(bin_addr2(2,num_srch_bins))
        allocate(bin_lats (2,num_srch_bins))
        allocate(bin_lons (2,num_srch_bins))

        dlat = pi/num_srch_bins

        do n=1,num_srch_bins
          bin_lats(1,n) = (n-1)*dlat - pih
          bin_lats(2,n) =     n*dlat - pih
          bin_lons(1,n) = zero
          bin_lons(2,n) = pi2
          bin_addr1(1,n) = grid1_size + 1
          bin_addr1(2,n) = 0
          bin_addr2(1,n) = grid2_size + 1
          bin_addr2(2,n) = 0
        end do

        do nele=1,grid1_size
          do n=1,num_srch_bins
            if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and.
     &          grid1_bound_box(2,nele) >= bin_lats(1,n)) then
              bin_addr1(1,n) = min(nele,bin_addr1(1,n))
              bin_addr1(2,n) = max(nele,bin_addr1(2,n))
            endif
          end do
        end do

        do nele=1,grid2_size
          do n=1,num_srch_bins
            if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and.
     &          grid2_bound_box(2,nele) >= bin_lats(1,n)) then
              bin_addr2(1,n) = min(nele,bin_addr2(1,n))
              bin_addr2(2,n) = max(nele,bin_addr2(2,n))
            endif
          end do
        end do

      case ('LATLON')
        write(nulou,*) 'Using lat/lon boxes to restrict search.'

        dlat = pi /num_srch_bins
        dlon = pi2/num_srch_bins

        allocate(bin_addr1(2,num_srch_bins*num_srch_bins))
        allocate(bin_addr2(2,num_srch_bins*num_srch_bins))
        allocate(bin_lats (2,num_srch_bins*num_srch_bins))
        allocate(bin_lons (2,num_srch_bins*num_srch_bins))

        n = 0
        do j=1,num_srch_bins
          do i=1,num_srch_bins
            n = n + 1

            bin_lats(1,n) = (j-1)*dlat - pih
            bin_lats(2,n) =     j*dlat - pih
            bin_lons(1,n) = (i-1)*dlon
            bin_lons(2,n) =     i*dlon
            bin_addr1(1,n) = grid1_size + 1
            bin_addr1(2,n) = 0
            bin_addr2(1,n) = grid2_size + 1
            bin_addr2(2,n) = 0
          end do
        end do

        num_srch_bins = num_srch_bins**2

        do nele=1,grid1_size
          do n=1,num_srch_bins
            if (grid1_bound_box(1,nele) <= bin_lats(2,n) .and.
     &          grid1_bound_box(2,nele) >= bin_lats(1,n) .and.
     &          grid1_bound_box(3,nele) <= bin_lons(2,n) .and.
     &          grid1_bound_box(4,nele) >= bin_lons(1,n)) then
                bin_addr1(1,n) = min(nele,bin_addr1(1,n))
                bin_addr1(2,n) = max(nele,bin_addr1(2,n))
            endif
          end do
        end do

        do nele=1,grid2_size
          do n=1,num_srch_bins
            if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and.
     &          grid2_bound_box(2,nele) >= bin_lats(1,n) .and.
     &          grid2_bound_box(3,nele) <= bin_lons(2,n) .and.
     &          grid2_bound_box(4,nele) >= bin_lons(1,n)) then
                bin_addr2(1,n) = min(nele,bin_addr2(1,n))
                bin_addr2(2,n) = max(nele,bin_addr2(2,n))
            endif
          end do
        end do

      case ('REDUCED')
        write(nulou,*)
     &  '|  Using reduced bins to restrict search. Reduced grids with'
        write(nulou,*)
     &  '| a maximum of 500*NBRBINS latitude circles can be treated'

        allocate(bin_addr2(2,num_srch_bins))
        allocate(bin_lats (2,num_srch_bins))
        allocate(bin_lons (2,num_srch_bins))
        allocate(bin_addr1_r(4,500*num_srch_bins))
        allocate(bin_lats_r (2,500*num_srch_bins))
        allocate(bin_lons_r (2,500*num_srch_bins))

        dlat = pi/num_srch_bins

        do n=1,num_srch_bins
          bin_lats(1,n) = (n-1)*dlat - pih
          bin_lats(2,n) =     n*dlat - pih
          bin_lons(1,n) = zero
          bin_lons(2,n) = pi2
          bin_addr2(1,n) = grid2_size + 1
          bin_addr2(2,n) = 0
        end do

        do nele=1,grid2_size
          do n=1,num_srch_bins
            if (grid2_bound_box(1,nele) <= bin_lats(2,n) .and.
     &          grid2_bound_box(2,nele) >= bin_lats(1,n)) then
              bin_addr2(1,n) = min(nele,bin_addr2(1,n))
              bin_addr2(2,n) = max(nele,bin_addr2(2,n))
            endif
          end do
        end DO

        bin_addr1_r(1,1) = 0
        bin_lats_r(1,1) = grid1_center_lat(1)
        num_srch_red = 1
        do nele=1,grid1_size-1
          if (grid1_center_lat(nele+1) ==
     &        grid1_center_lat(nele)) THEN
              bin_addr1_r(2,num_srch_red) = nele+1
          else IF (grid1_center_lat(nele+1) /=
     &        grid1_center_lat(nele)) THEN
              bin_addr1_r(1,num_srch_red+1) = nele+1
              bin_lats_r(2,num_srch_red) = grid1_center_lat(nele+1)
              bin_lats_r(1,num_srch_red+1) =
     &            bin_lats_r(2,num_srch_red)
              num_srch_red = num_srch_red+1
          ENDIF
        end DO

        DO nele = 1,num_srch_red-1
          bin_addr1_r(3,nele)=bin_addr1_r(1,nele+1)
          bin_addr1_r(4,nele)=bin_addr1_r(2,nele+1)
        enddo
        bin_addr1_r(3,num_srch_red) = bin_addr1_r(1,num_srch_red-1)
        bin_addr1_r(4,num_srch_red) = bin_addr1_r(2,num_srch_red-1)

      case default
        stop 'unknown search restriction method'
      end select
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Leaving routine grid_init'
         WRITE (UNIT = nulou,FMT = *)' '
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
!-----------------------------------------------------------------------

      end subroutine grid_init

!***********************************************************************

      subroutine free_grids

!-----------------------------------------------------------------------
!
!     subroutine to deallocate allocated arrays
!
!-----------------------------------------------------------------------
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Entering routine free_grid'
         WRITE (UNIT = nulou,FMT = *)' '
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
      deallocate(grid1_mask, grid2_mask,
     &    grid1_center_lat, grid1_center_lon,
     &    grid2_center_lat, grid2_center_lon,
     &    grid1_area, grid2_area,
     &    grid1_frac, grid2_frac,
     &    grid1_dims, grid2_dims)

      IF (restrict_TYPE == 'REDUCED') then
          deallocate( grid1_bound_box, grid2_bound_box,
     &        bin_addr1_r, bin_addr2,
     &        bin_lons, bin_lats,
     &        bin_lats_r, bin_lons_r)
      else
          deallocate( grid1_bound_box, grid2_bound_box,
     &        bin_addr1, bin_addr2,
     &        bin_lats, bin_lons)
      endif

      if (.not. luse_grid_centers) then
        deallocate(grid1_corner_lat, grid1_corner_lon,
     &             grid2_corner_lat, grid2_corner_lon)
      ENDIF
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Leaving routine free_grid'
         WRITE (UNIT = nulou,FMT = *)' '
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!-----------------------------------------------------------------------

      end subroutine free_grids

!***********************************************************************

      end module grids

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


module f90Types

  type stormStructType
     integer,dimension(:),pointer :: nodes
     ! 5 nodes that define the storm structure
     ! for stratiform, with BB, nodes[0] is the storm top,
     ! nodes[1] is the BB top,
     ! nodes[2] is the BB peak, nodes[3] is the BB bottom,
     ! and nodes[4] is the lowest
     ! clutter free gate (0<=nodes[0]<nodes[1]<nodes[2]
     ! <nodes[3]<nodes[4]<ngates)
     ! for convective, nodes[3] is not used
     ! the C convention is used the gates are
     ! numbered from 0 to ngates-1
     integer   ::  iSurf      ! surface gate number
     real      ::  freezH     ! freezing height - not used
     integer   ::  rainType;  ! rainType -1 stratiform
  end type stormStructType

  type radarDataType
     integer                    :: ngates     ! number of gates
     real,dimension(:),pointer  :: z13obs     ! observed Ku-reflectivities
     real,dimension(:),pointer  :: z35obs     ! observed Ka-reflectivities
     real                       :: xlong      ! longitude -not used
     real                       :: xlat       ! latitude -not used
     real                       :: pia13srt   ! Ku-band SRT PIA
     real                       :: relPia13srt   ! Ku-band SRT PIA
     real                       :: pia35srt   ! Ka-band SRT PIA
     real                       :: relPia35srt   ! Ka-band SRT PIA
     real                       :: dr         ! gate size
     real,dimension(:),pointer  :: hh;        ! hh[i] is the height of gate [i]
     real                       :: hfreez
     real			:: sigmaZeroKu
     real			:: sigmaZeroKa
  end type radarDataType

  type  radarRetType

     integer   ::  ngates     ! number of gates
     integer   ::  nMemb      ! number of members
     integer   ::  nmfreq     ! # of simulated passive microwave frequencies
     real,dimension(:),pointer :: z13c        ! effective reflectivity
                                              ! (attenuation corrected)
                                              ! at Ku-band
     real,dimension(:),pointer :: z35mod0     ! simulated observations at Ka-band
!  SFM  begin  06/16/2014; for M. Grecu, multiple scattering
     real,dimension(:),pointer :: dz35ms      !  multiple scattering effect
!  SFM  end    06/16/2014
     real,dimension(:),pointer :: z35         ! simulated observations at Ka-band
     real,dimension(:),pointer :: pwc         ! precipitation water content
                                              ! (g/m3)
     real,dimension(:),pointer :: rrate       ! rain rate (mm/h)
     real,dimension(:),pointer :: d0          ! median diameter (mm)
     real,dimension(:),pointer :: log10dNw    !
     real,dimension(:),pointer :: tb          ! simulated brightness temperatures
     real,dimension(:),pointer :: emTb          ! simulated brightness temperatures
     real,dimension(:),pointer :: emis          ! emissivity
     integer,dimension(:),pointer  ::  imu    ! mu index of the look up table
     integer,dimension(:),pointer  ::  iwc
     integer,dimension(:),pointer  ::  icc
                                              ! index of RH profile (from 1 to nc)
                                              ! nc is the number of possible
                                              ! RH profiles see cloud.f90
     integer,dimension(:),pointer   ::  jcc
                                              ! index of cloud profile (from 1 to nc)
     real,dimension(:),pointer      ::  sfc_wind, sfc_windU, sfc_windV
                                              ! surface wind speed
     real, dimension(:),pointer     ::  pia13
     real, dimension(:),pointer     ::  pia35
     real, dimension(:),pointer     ::  simSigmaZeroKu
     real, dimension(:),pointer     ::  simSigmaZeroKa
     real, dimension(:),pointer     ::  z35mMean
     real, dimension(:),pointer     ::  z35mSig
     real                           ::  pia13mMean, pia35mMean, pia13mSig, pia35mSig
     integer                        ::  ntpw
     real, dimension(:),pointer     ::  tpw
     real, dimension(:),pointer     ::  tpwCldMod
     real, dimension(:),pointer     ::  logdNw
                                             ! the last four variables are not retrieved
                                             ! they are randomly set and
                                             ! specify the conditions
     ! in which the retrievals and
     ! associated brightness temperatures are derived
  end type radarRetType

  type  retParamType

  !
  !  F=wz*SUM(zsim,ka-zobs,ka)**2+w13*(pia13-pia13srt)**2+
  !  w35*(pia35,sim-pia35srt)**2
  !  wz the weight of the reflectivity term
  !  w13 the weight of the pia squared difference at ku-band
  !  w35 the weight of the pia squared difference at ka-band
  !  z13thresh - threshold (dBZ) to determine
  !  the Ku-band observations used in the algorithm
  !  z35thresh - threshold (dBZ) to determine the Ka-band observations
  !  used in the algorithm

     real :: wz, w13,  w35,  z13thresh,  z35thresh
  end type retParamType

end module f90Types


       subroutine iff_diffkk(str)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c purpose: do a differential Kramers-Kronig transform
c arguments:
c      str     command line to performd                 [in]
c
       implicit none
       include 'consts.h'
       include 'keywrd.h'
       include 'arrays.h'
       include 'spline.h'
       save
       character*(*)     str
       character*512   path, defkey(3)*64,   en_arr, f2_arr, name1
       double precision  a_e(maxpts), tmpx(maxpts)
       double precision  a_f1(maxpts), a_f2(maxpts)
       double precision  ewid, estep
       logical   do_f1, do_f2
       integer   jen, jf,  ier, i, k, istrln, ilen
       integer   ndfkey, npts, iret, iz, jdot
       integer  iff_eval, iff_eval_dp, iff_eval_in
       integer  clcalc
       external iff_eval, iff_eval_dp, iff_eval_in
       external istrln, clcalc
c
       call iff_sync
       call gettxt('&install_dir', path)
       call warn(2, ' WARNING: diffkk is not working correctly ')

       estep = one
       do_f1 = .true.
       do_f2 = .false.
       ilen  = istrln(path)
       path  = path(1:ilen)//'/cldata/'
       ilen  = istrln(path)
       iz    = 1
       name1 = undef
       do i = 1, maxpts
          a_e(i)  = zero
          a_f1(i) = zero
          a_f2(i) = zero
       enddo
       ewid = zero

       call bkeys(str, mkeys, keys, values, nkeys)

       ndfkey    = 2
       defkey(1) = 'iz'
       defkey(2) = 'energy'
       do 100 i = 1, nkeys
          k = istrln( keys(i))
          if ((values(i).eq.undef).and.(i.le.ndfkey)) then
             values(i) = keys(i)
             keys(i)   = defkey(i)
          end if
          if ((keys(i).eq.'iz').or.(keys(i).eq.'z'))  then
             ier = iff_eval_in(values(i),iz)
          elseif (keys(i).eq.'group') then
             name1 = values(i)
          elseif (keys(i).eq.'width') then
             call str2dp(values(i),ewid, ier)
          elseif (keys(i).eq.'do_f1') then
             call str2lg(values(i),do_f1, ier)
          elseif (keys(i).eq.'do_f2') then
             call str2lg(values(i),do_f2, ier)
          elseif (keys(i).eq.'energy') then
             en_arr = values(i)
             call lower(en_arr)
          elseif (keys(i).eq.'f2') then
             f2_arr = values(i)
             call lower(f2_arr)
          else
             messg = keys(i)(1:k)//' " will be ignored'
             call warn(1,' *** diffkk: unknown keyword " '//messg)
          end if
 100   continue
c
c get/resolve array names
       if (name1.eq.undef) then
          jdot = index(en_arr,'.')
          if (jdot.ne.0) name1 = en_arr(1:jdot-1)
       endif
       if (name1.eq.undef) then
          call warn(2, ' diffkk: can''t determine group name')
          return
       endif
       call fixnam(name1,1)
       call lower(name1)
       jdot = istrln(name1)
       jen  = iff_eval(en_arr, name1, a_e,  npts)
       jen  = iff_eval(f2_arr, name1, a_f2, npts)
       if ((npts.ge.1) .and. (iz.ge.4)) then
cc          iret = clcalc(iz, path, npts, a_e, a_f1, a_f2)
          call kkmclr(npts, a_e, a_f2, a_f1)
       endif
c
c  make array of f1
       if (do_f1) then
          if (ewid.gt.zero) then
             call conv_lor(ewid, npts, a_e, a_f1,estep,tmpx)
             call set_array('f1', name1, tmpx, npts, 1)
          else
             call set_array('f1', name1, a_f1, npts, 1)
          endif
       endif
c
c  make array of f2
       if (do_f2) then
          if (ewid.gt.zero) then
             call conv_lor(ewid, npts, a_e, a_f2,estep,tmpx)
             call set_array('f2', name1, tmpx, npts, 1)
          else
             call set_array('f2', name1, a_f2, npts, 1)
          endif
       endif
c
c
       return
c end  subroutine diffkk
       end


! <clmete.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine CLMETE

! The subroutine closes all meteorological data input files.
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!    xx Dat 201x  Name: Line  Description of Change
!
! ----------------------------------------------------------------------------------

      use mod_main
      use mod_site
      use mod_mete

         implicit none

! Close temperature file

      call clifil(TEMPFN,TEMPUN,TEMPFE,TEMPFM)

! Close wind file

      call clifil(WINDFN,WINDUN,WINDFE,WINDFM)

! Close turbulence sigma-vw file

      call clifil(SDVWFN,SDVWUN,SDVWFE,SDVWFM)

! Close aerodynamic resistance file

      call clifil(AEROFN,AEROUN,AEROFE,AEROFM)

! Close mixing height file

      call clifil(HMIXFN,HMIXUN,HMIXFE,HMIXFM)

!_LHS_08_Oct_Start:

! Close friction velocity file

      call clifil(USTRFN,USTRUN,USTRFE,USTRFM)

! Close sensible heat flux file

      call clifil(SHFLFN,SHFLUN,SHFLFE,SHFLFM)

! Close latent heat flux file

      call clifil(LHFLFN,LHFLUN,LHFLFE,LHFLFM)

! Close land-use file

      call clifil(LANUFN,LANUUN,LANUFE,LANUFM)

!MSK start
! Close MM5 met files

! Close surface moisture flux file

      call clifil(MFLXFN,MFLXUN,MFLXFE,MFLXFM)

! Close surface momentum stress file

      call clifil(TAUSFN,TAUSUN,TAUSFE,TAUSFM)

!MSK Eddy diffusivity files are nowhere used
!MSK Close heat diffusivity file
!MSK      call clifil(KZ_HFN,KZ_HUN,KZ_HFE,KZ_HFM)
!MSK Close momentum diffusivity file
!MSK      call clifil(KZ_MFN,KZ_MUN,KZ_MFE,KZ_MFM)
!MSK end

!MSK start close TAPM input files

! Close 3D insitu temperature file

      call clifil(INS_TFN,INS_TUN,INS_TFE,INS_TFM)

! Close 3D potential temperature file

      call clifil(POT_TFN,POT_TUN,POT_TFE,POT_TFM)

! Close potential temperature scale file

      call clifil(GPOTFN,GPOTUN,GPOTFE,GPOTFM)

! Close potential temperature scale file

      call clifil(PTSTRFN,PTSTRUN,PTSTRFE,PTSTRFM)

! Close potential virtual temperature file

      call clifil(PVSTRFN,PVSTRUN,PVSTRFE,PVSTRFM)

! Close convective velocity file

      call clifil(WSTRFN,WSTRUN,WSTRFE,WSTRFM)

! Close total solar radiation file

      call clifil(TSRADFN,TSRADUN,TSRADFE,TSRADFM)

! Close ground temperature file

      call clifil(GTMPFN,GTMPUN,GTMPFE,GTMPFM)

!MSK end

! Close precipitation file

      call clifil(PRECFN,PRECUN,PRECFE,PRECFM)

! Close relative humidity file

      call clifil(RHUMFN,RHUMUN,RHUMFE,RHUMFM)

! Close cloud cover file

      call clifil(CLOUFN,CLOUUN,CLOUFE,CLOUFM)

      RETURN

! End of subroutine CLMETE

      end subroutine clmete


!>    @brief declaration for all AD gradient objects
      MODULE g_arrays
        IMPLICIT NONE

!       hydraulic potential
        DOUBLE PRECISION, ALLOCATABLE :: g_head(:,:,:,:)
!       hydraulic pressure
        DOUBLE PRECISION, ALLOCATABLE :: g_pres(:,:,:,:)

        DOUBLE PRECISION, ALLOCATABLE :: g_conc(:,:,:,:,:)

!       temperature
        DOUBLE PRECISION, ALLOCATABLE :: g_temp(:,:,:,:)

        DOUBLE PRECISION, ALLOCATABLE :: g_tsal(:,:,:,:)

!       inverse
        DOUBLE PRECISION, ALLOCATABLE :: g_propunit(:,:,:)

!       coefficients for linear system solver
        DOUBLE PRECISION, ALLOCATABLE :: g_a(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_b(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_c(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_d(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_e(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_f(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_g(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_w(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_x(:,:,:,:)

!       storing old temp,head,conc for iteration
        DOUBLE PRECISION, ALLOCATABLE :: g_headold(:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_tempold(:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_presold(:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_concold(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_prad(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_conc_conv(:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_omp_dglobal(:,:,:)

!       boundary conditions
        DOUBLE PRECISION, ALLOCATABLE :: g_dbc_data(:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_sdata(:,:)

        DOUBLE PRECISION, ALLOCATABLE :: g_diff_c(:)
        DOUBLE PRECISION, ALLOCATABLE :: g_mmas_c(:)

        DOUBLE PRECISION, ALLOCATABLE :: g_bcperiod(:,:,:,:)
        DOUBLE PRECISION, ALLOCATABLE :: g_delta_time(:)
        DOUBLE PRECISION, ALLOCATABLE :: g_simtime(:)

        CONTAINS

!>    @brief dummy routine for TAF (content moved to "g_alloc_arrays")
        SUBROUTINE g_arrays_constructor
        RETURN
        END SUBROUTINE g_arrays_constructor

!>    @brief dummy routine for TAF (content moved to "g_dealloc_arrays")
        SUBROUTINE g_arrays_destructor
        RETURN
        END SUBROUTINE g_arrays_destructor

      END MODULE g_arrays


	subroutine chkcrg(natom,i_atinf,chrgv4,resnummax,isitsf)

      pointer (i_atinf,atinf)
      real chrgv4(natom)
	character*15 atinf(natom)
      character*80 line
      character*4 err,strng,resnme,resnum,rsnm
	integer resnummax,tmp
	logical isitsf

      crgsm=0.0
      rsnm='    '
      resnme='    '
c	write(6,*)' '

c b+++++++++++++++++++++++++++++++++++++++++++++++
      if (isitsf) then
	  do i=1,natom
	    crg=chrgv4(i)
          resnum=atinf(i)(12:15)
          strng=atinf(i)(7:10)
          if(resnum.ne.rsnm.or.strng.ne.resnme)then
            if(abs(crgsm).gt.1.0e-4)then
              eror=abs(crgsm)-1.0
              if(abs(eror).gt.1.0e-4)
     &	      write(6,10)resnme,rsnm,crgsm
            endif
            resnme=strng
            rsnm=resnum
            crgsm=crg
          else
            crgsm=crgsm+crg
          endif
c specific section to find maximum residue number
          read(resnum,'(i4)')itmp
	    if(itmp.gt.resnummax) resnummax=itmp
	  end do
	else
c e++++++++++++++++++++++++++++++++++++++++++++
	  do i=1,natom
	    crg=chrgv4(i)
          resnum=atinf(i)(12:15)
          strng=atinf(i)(7:10)
          if(resnum.ne.rsnm.or.strng.ne.resnme)then
            if(abs(crgsm).gt.1.0e-4)then
              eror=abs(crgsm)-1.0
              if(abs(eror).gt.1.0e-4)
     &	      write(6,10)resnme,rsnm,crgsm
            endif
            resnme=strng
            rsnm=resnum
            crgsm=crg
          else
            crgsm=crgsm+crg
          endif
	  end do
	endif

      if(abs(crgsm).gt.1.0e-4)then
        eror=abs(crgsm)-1.0
        if(abs(eror).gt.1.0e-4)
     &    write(6,10)resnme,rsnm,crgsm
      endif
c	write(6,*)' '
10	format('!!! WARNING: ',2a4,' has a net charge of ',f8.4)
      end