      module commdot
!***********************************************************************
! $Id: commdot.f,v 1.1 2006/05/17 15:23:20 zvd Exp $
!***********************************************************************
!  Copyright, 2002, 2004,  The  Regents of the University of California.
!  This  program  was  prepared by  the  Regents  of the  University  of
!  California  at Los Alamos National Laboratory (the  University) under
!  contract No. W-7405-ENG-36 with the U. S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is  granted to the  public to copy  and  use this software
!  without  charge,  provided that this  Notice  and  any  statement  of
!  authorship are reproduced on all copies. Neither the U. S. Government
!  nor  the  University  makes any  warranty,  express  or  implied,  or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!     Module containing variables related to the source mass flux
!     information
!
!     Identifier      Type     Description
!
!     n_sources       integer  number of individual solute sources
!     n_size_mdot     integer  total size of mdot and time arrays
!     end_no_mdot     integer  for each source, the index in the array
!                                of the last entry in the mdot array for
!                                that source, array of size n_sources
!     column_number   integer  array defining the column number where
!                                the mdot information for each source
!                                region is being read in (do not count
!                                the time array as one, it is assumed to
!                                be the first column), array of size
!                                n_sources
!     mdot            real*8   array of mass flux values for all sources
!                                in the time, mdot curves, array of
!                                size n_size_mdot
!     time_mdot       real*8   array of times associated with the time,
!                                mdot curves, array of size n_size_mdot
!     mdot_total      real*8   array of cumulative moles that have
!                                entered system for each source during
!                                the current time interval,
!                                array of size nsources + 1
!     mdot_out_unit  integer   unit number of mdot_out_file
!     mdot_out_file  char*100  name of file to be used for output of the
!                                integrated source functions
!***********************************************************************

      integer n_sources
      integer n_size_mdot
      integer mdot_out_unit
      integer, allocatable :: end_no_mdot(:)
      integer, allocatable :: column_number(:)
      real*8, allocatable :: mdot(:)
      real*8, allocatable :: time_mdot(:)
      real*8, allocatable :: mdot_total(:,:)
      character(100) :: mdot_out_file

      end module commdot


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine fertin(tomatch,curfert,savedfert)

      implicit none
      include 'const.inc'
      include 'fertil.inc'
      include 'npool.inc'

c ... Argument declarations
      character*5 tomatch
      character*5 curfert
      double precision savedfert

c ... Read in the new fert type

c ... Local variables
      integer   ii, FERTLNS
      double precision temp
      character fromdat*5, name*20, string*80

c ... Number of lines to read for each fert type
      parameter (FERTLNS = 8)

      open(unit=11, file='fert.100',status='OLD')
      rewind(11)
20    continue
      read(11, 100, end=200) fromdat
      if (tomatch .ne. fromdat) then
        do 25 ii = 1, FERTLNS
          read(11, *) temp, name
25      continue
        goto 20
      else
        read(11, *) feramt(N), name
        call ckdata('schedl','feramt',name)
        read(11, *) feramt(P), name
        call ckdata('schedl','feramt',name)
        read(11, *) feramt(S), name
        call ckdata('schedl','feramt',name)
        read(11, *) aufert, name
        call ckdata('schedl','aufert',name)
        read(11, *) ninhib, name
        call ckdata('schedl','ninhib',name)
        read(11, *) temp, name
        ninhtm = int(temp)
        call ckdata('schedl','ninhtm',name)
        read(11, *) frac_nh4_fert, name
        call ckdata('schedl','frac_n',name)
        read(11, *) frac_no3_fert, name
        call ckdata('schedl','frac_n',name)
        if (feramt(N) .gt. 0.0) then
          if (abs(1.0 - (frac_nh4_fert + frac_no3_fert)) .gt.
     &        0.000001) then
            call message('Error in fert.100 file!')
            call message('frac_nh4_fert + frac_no3_fert != 1.0')
            STOP
          endif
        endif
        savedfert = aufert
        close(11)
        curfert = tomatch
      endif

      return

100   format(a5)

200   continue
      call message('  Error reading in values from the fert.100 file.')
      string = '   Looking for fert type: ' // tomatch
      call message(string)
      STOP

      end


C $Header: /u/gcmpack/MITgcm/verification/tutorial_plume_on_slope/code/CPP_OPTIONS.h,v 1.1 2006/04/20 16:45:12 jmc Exp $
C $Name: checkpoint65t $

C CPP flags controlling particular source code features

C o Shortwave heating as extra term in external_forcing.F
C Note: this should be a run-time option

C o Include/exclude phi_hyd calculation code

C o Include/exclude call to S/R CONVECT

C o Include/exclude call to S/R CALC_DIFFUSIVITY

C o Include/exclude Implicit vertical advection code

C o Include/exclude nonHydrostatic code

C o Include pressure loading code

C o Use "Exact Convervation" of fluid in Free-Surface formulation
C   so that d/dt(eta) is exactly equal to - Div.Transport

C o Allow the use of Non-Linear Free-Surface formulation
C   this implies that surface thickness (hFactors) vary with time

C o Use "OLD" UV discretisation near boundaries (*not* recommended)
C   Note - only works with  #undef NO_SLIP_LATERAL  in calc_mom_rhs.F
C          because the old code did not have no-slip BCs

C o Execution environment support options
CBOP
C     !ROUTINE: CPP_EEOPTIONS.h
C     !INTERFACE:
C     include "CPP_EEOPTIONS.h"
C
C     !DESCRIPTION:
C     *==========================================================*
C     | CPP\_EEOPTIONS.h                                         |
C     *==========================================================*
C     | C preprocessor "execution environment" supporting        |
C     | flags. Use this file to set flags controlling the        |
C     | execution environment in which a model runs - as opposed |
C     | to the dynamical problem the model solves.               |
C     | Note: Many options are implemented with both compile time|
C     |       and run-time switches. This allows options to be   |
C     |       removed altogether, made optional at run-time or   |
C     |       to be permanently enabled. This convention helps   |
C     |       with the data-dependence analysis performed by the |
C     |       adjoint model compiler. This data dependency       |
C     |       analysis can be upset by runtime switches that it  |
C     |       is unable to recoginise as being fixed for the     |
C     |       duration of an integration.                        |
C     |       A reasonable way to use these flags is to          |
C     |       set all options as selectable at runtime but then  |
C     |       once an experimental configuration has been        |
C     |       identified, rebuild the code with the appropriate  |
C     |       options set at compile time.                       |
C     *==========================================================*
CEOP

C     In general the following convention applies:
C     ALLOW  - indicates an feature will be included but it may
C     CAN      have a run-time flag to allow it to be switched
C              on and off.
C              If ALLOW or CAN directives are "undef'd" this generally
C              means that the feature will not be available i.e. it
C              will not be included in the compiled code and so no
C              run-time option to use the feature will be available.
C
C     ALWAYS - indicates the choice will be fixed at compile time
C              so no run-time option will be present

C=== Macro related options ===
C--   Control storage of floating point operands
C     On many systems it improves performance only to use
C     8-byte precision for time stepped variables.
C     Constant in time terms ( geometric factors etc.. )
C     can use 4-byte precision, reducing memory utilisation and
C     boosting performance because of a smaller working set size.
C     However, on vector CRAY systems this degrades performance.
C     Enable to switch REAL4_IS_SLOW from genmake2 (with LET_RS_BE_REAL4):

C--   Control use of "double" precision constants.
C     Use D0 where it means REAL*8 but not where it means REAL*16

C--   Enable some old macro conventions for backward compatibility

C=== IO related options ===
C--   Flag used to indicate whether Fortran formatted write
C     and read are threadsafe. On SGI the routines can be thread
C     safe, on Sun it is not possible - if you are unsure then
C     undef this option.

C--   Flag used to indicate whether Binary write to Local file (i.e.,
C     a different file for each tile) and read are thread-safe.

C--   Flag to turn off the writing of error message to ioUnit zero

C--   Alternative formulation of BYTESWAP, faster than
C     compiler flag -byteswapio on the Altix.

C--   Flag to turn on old default of opening scratch files with the
C     STATUS='SCRATCH' option. This method, while perfectly FORTRAN-standard,
C     caused filename conflicts on some multi-node/multi-processor platforms
C     in the past and has been replace by something (hopefully) more robust.

C--   Flag defined for eeboot_minimal.F, eeset_parms.F and open_copy_data_file.F
C     to write STDOUT, STDERR and scratch files from process 0 only.
C WARNING: to use only when absolutely confident that the setup is working
C     since any message (error/warning/print) from any proc <> 0 will be lost.

C=== MPI, EXCH and GLOBAL_SUM related options ===
C--   Flag turns off MPI_SEND ready_to_receive polling in the
C     gather_* subroutines to speed up integrations.

C--   Control MPI based parallel processing
CXXX We no longer select the use of MPI via this file (CPP_EEOPTIONS.h)
CXXX To use MPI, use an appropriate genmake2 options file or use
CXXX genmake2 -mpi .
CXXX #undef  1

C--   Control use of communication that might overlap computation.
C     Under MPI selects/deselects "non-blocking" sends and receives.
C--   Control use of communication that is atomic to computation.
C     Under MPI selects/deselects "blocking" sends and receives.

C--   Control XY periodicity in processor to grid mappings
C     Note: Model code does not need to know whether a domain is
C           periodic because it has overlap regions for every box.
C           Model assume that these values have been
C           filled in some way.

C--   disconnect tiles (no exchange between tiles, just fill-in edges
C     assuming locally periodic subdomain)

C--   Always cumulate tile local-sum in the same order by applying MPI allreduce
C     to array of tiles ; can get slower with large number of tiles (big set-up)

C--   Alternative way of doing global sum without MPI allreduce call
C     but instead, explicit MPI send & recv calls. Expected to be slower.

C--   Alternative way of doing global sum on a single CPU
C     to eliminate tiling-dependent roundoff errors. Note: This is slow.

C=== Other options (to add/remove pieces of code) ===
C--   Flag to turn on checking for errors from all threads and procs
C     (calling S/R STOP_IF_ERROR) before stopping.

C--   Control use of communication with other component:
C     allow to import and export from/to Coupler interface.

C--   Activate some pieces of code for coupling to GEOS AGCM

CBOP
C     !ROUTINE: CPP_EEMACROS.h
C     !INTERFACE:
C     include "CPP_EEMACROS.h"
C     !DESCRIPTION:
C     *==========================================================*
C     | CPP_EEMACROS.h
C     *==========================================================*
C     | C preprocessor "execution environment" supporting
C     | macros. Use this file to define macros for  simplifying
C     | execution environment in which a model runs - as opposed
C     | to the dynamical problem the model solves.
C     *==========================================================*
CEOP

C     In general the following convention applies:
C     ALLOW  - indicates an feature will be included but it may
C     CAN      have a run-time flag to allow it to be switched
C              on and off.
C              If ALLOW or CAN directives are "undef'd" this generally
C              means that the feature will not be available i.e. it
C              will not be included in the compiled code and so no
C              run-time option to use the feature will be available.
C
C     ALWAYS - indicates the choice will be fixed at compile time
C              so no run-time option will be present

C     Flag used to indicate which flavour of multi-threading
C     compiler directives to use. Only set one of these.
C     USE_SOLARIS_THREADING  - Takes directives for SUN Workshop
C                              compiler.
C     USE_KAP_THREADING      - Takes directives for Kuck and
C                              Associates multi-threading compiler
C                              ( used on Digital platforms ).
C     USE_IRIX_THREADING     - Takes directives for SGI MIPS
C                              Pro Fortran compiler.
C     USE_EXEMPLAR_THREADING - Takes directives for HP SPP series
C                              compiler.
C     USE_C90_THREADING      - Takes directives for CRAY/SGI C90
C                              system F90 compiler.

C--   Define the mapping for the _BARRIER macro
C     On some systems low-level hardware support can be accessed through
C     compiler directives here.

C--   Define the mapping for the BEGIN_CRIT() and  END_CRIT() macros.
C     On some systems we simply execute this section only using the
C     master thread i.e. its not really a critical section. We can
C     do this because we do not use critical sections in any critical
C     sections of our code!

C--   Define the mapping for the BEGIN_MASTER_SECTION() and
C     END_MASTER_SECTION() macros. These are generally implemented by
C     simply choosing a particular thread to be "the master" and have
C     it alone execute the BEGIN_MASTER..., END_MASTER.. sections.

CcnhDebugStarts
C      Alternate form to the above macros that increments (decrements) a counter each
C      time a MASTER section is entered (exited). This counter can then be checked in barrier
C      to try and detect calls to BARRIER within single threaded sections.
C      Using these macros requires two changes to Makefile - these changes are written
C      below.
C      1 - add a filter to the CPP command to kill off commented _MASTER lines
C      2 - add a filter to the CPP output the converts the string N EWLINE to an actual newline.
C      The N EWLINE needs to be changes to have no space when this macro and Makefile changes
C      are used. Its in here with a space to stop it getting parsed by the CPP stage in these
C      comments.
C      #define IF ( a .EQ. 1 ) THEN  IF ( a .EQ. 1 ) THEN  N EWLINE      CALL BARRIER_MS(a)
C      #define ENDIF    CALL BARRIER_MU(a) N EWLINE        ENDIF
C      'CPP = cat $< | $(TOOLSDIR)/set64bitConst.sh |  grep -v '^[cC].*_MASTER' | cpp  -traditional -P'
C      .F.f:
C      $(CPP) $(DEFINES) $(INCLUDES) |  sed 's/N EWLINE/\n/' > $@
CcnhDebugEnds

C--   Control storage of floating point operands
C     On many systems it improves performance only to use
C     8-byte precision for time stepped variables.
C     Constant in time terms ( geometric factors etc.. )
C     can use 4-byte precision, reducing memory utilisation and
C     boosting performance because of a smaller working
C     set size. However, on vector CRAY systems this degrades
C     performance.
C- Note: global_sum/max macros were used to switch to  JAM routines (obsolete);
C  in addition, since only the R4 & R8 S/R are coded, GLOBAL RS & RL macros
C  enable to call the corresponding R4 or R8 S/R.

C- Note: a) exch macros were used to switch to  JAM routines (obsolete)
C        b) exch R4 & R8 macros are not practically used ; if needed,
C           will directly call the corrresponding S/R.

C--   Control use of JAM routines for Artic network (no longer supported)
C     These invoke optimized versions of "exchange" and "sum" that
C     utilize the programmable aspect of Artic cards.
CXXX No longer supported ; started to remove JAM routines.
CXXX #ifdef LETS_MAKE_JAM
CXXX #define CALL GLOBAL_SUM_R8 ( a, b) CALL GLOBAL_SUM_R8_JAM ( a, b)
CXXX #define CALL GLOBAL_SUM_R8 ( a, b ) CALL GLOBAL_SUM_R8_JAM ( a, b )
CXXX #define CALL EXCH_XY_RS ( a, b ) CALL EXCH_XY_R8_JAM ( a, b )
CXXX #define CALL EXCH_XY_RL ( a, b ) CALL EXCH_XY_R8_JAM ( a, b )
CXXX #define CALL EXCH_XYZ_RS ( a, b ) CALL EXCH_XYZ_R8_JAM ( a, b )
CXXX #define CALL EXCH_XYZ_RL ( a, b ) CALL EXCH_XYZ_R8_JAM ( a, b )
CXXX #endif

C--   Control use of "double" precision constants.
C     Use d0 where it means REAL*8 but not where it means REAL*16

C--   Substitue for 1.D variables
C     Sun compilers do not use 8-byte precision for literals
C     unless .Dnn is specified. CRAY vector machines use 16-byte
C     precision when they see .Dnn which runs very slowly!

C--   Set the format for writing processor IDs, e.g. in S/R eeset_parms
C     and S/R open_copy_data_file. The default of I9.9 should work for
C     a long time (until we will use 10e10 processors and more)

C o Include/exclude code specific to the ECCO/SEALION version.
C   AUTODIFF or EXF package.
C   Currently controled by a single header file
C   For this to work, PACKAGES_CONFIG.h needs to be included!
cph#if (defined (ALLOW_AUTODIFF) || cph     defined (ALLOW_ECCO) || cph     defined (ALLOW_EXF))
cph# include "ECCO_CPPOPTIONS.h"
cph#endif

C--  File gsw_teos10.F: routines that compute quantities related to seawater.
C--   Contents
C--   TEOS-10 routines (Gibbs seawater, GSW)
C--   o GSW_PT_FROM_CT: function to compute potential temperature
C--              from conservative temperature and absolute salinity
C--   o GSW_CT_FROM_PT: function to compute conservative temperature with
C--              from potential temperature and absolute salinity
C--   o GSW_GIBBS_PT0_PT0: function to compute specific Gibbs free energy
C--              from potential temperature and absolute salinity

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP
C     !ROUTINE: GSW_PT_FROM_CT
C     !INTERFACE:
      Real*8 FUNCTION GSW_PT_FROM_CT(SA,CT)
C     !DESCRIPTION: \bv
C     *=============================================================*
C     | S/R  GSW_PT_FROM_CT
C     | o compute potential temperature at reference level 0 dbar
C     |   from conservative temperature (CT) and absolute
C     |    salinity (SA)
C     | o this is a more or less shameless copy of the teos-10 code
C     |   available at http://www.teos-10.org
C     *=============================================================*
C     \ev

C     !USES:
      IMPLICIT NONE

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     SA :: Absolute Salinity                               (g/kg)
C     CT :: Conservative Temperature                        (deg C)
      Real*8 SA,CT

C     !FUNCTIONS:
C     == Functions ==
CML      Real*8 gsw_gibbs
      Real*8 gsw_gibbs_pt0_pt0
      Real*8 gsw_ct_from_pt
CML      EXTERNAL gsw_gibbs, gsw_gibbs_pt0_pt0, gsw_ct_from_pt
      EXTERNAL gsw_gibbs_pt0_pt0, gsw_ct_from_pt

C     !LOCAL VARIABLES:
C     == Local variables ==
      INTEGER n0, n2
      Real*8 s1, p0, cp0
      Real*8 a0, a1, a2, a3, a4, a5, b0, b1, b2, b3
      Real*8 a5ct, b3ct, ct_factor, pt_num, pt_den, ct_diff
      Real*8 pt, pt_old, ptm, dct_dpt
CEOP

      cp0 = 3991.86795711963D0

      n0 = 0
      n2 = 2

      s1 = SA * 35.D0 / 35.16504D0
      p0 = 0.D0

      a0 = -1.446013646344788D-2
      a1 = -3.305308995852924D-3
      a2 =  1.062415929128982D-4
      a3 =  9.477566673794488D-1
      a4 =  2.166591947736613D-3
      a5 =  3.828842955039902D-3

      b0 =  1.000000000000000D+0
      b1 =  6.506097115635800D-4
      b2 =  3.830289486850898D-3
      b3 =  1.247811760368034D-6

      a5ct = a5*CT
      b3ct = b3*CT

      ct_factor = (a3 + a4*s1 + a5ct)
      pt_num    = a0 + s1*(a1 + a2*s1) + CT*ct_factor
      pt_den    = b0 + b1*s1 + CT*(b2 + b3ct)
      pt        = (pt_num)/(pt_den)

      dct_dpt   = (pt_den)/(ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)

C     start the 1.5 iterations through the modified Newton-Rapshon
C     iterative method.

      ct_diff = gsw_ct_from_pt(sa,pt) - CT
      pt_old  = pt
      pt      = pt_old - (ct_diff)/dct_dpt
      ptm     = 0.5D0*(pt + pt_old)

      dct_dpt = -(ptm + 273.15D0)*gsw_gibbs_pt0_pt0(sa,ptm)/cp0

      pt             = pt_old - (ct_diff)/dct_dpt
      ct_diff        = gsw_ct_from_pt(sa,pt) - CT
      pt_old         = pt
      GSW_PT_FROM_CT = pt_old - (ct_diff)/dct_dpt

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP
C     !ROUTINE: GSW_CT_FROM_PT
C     !INTERFACE:
      Real*8 FUNCTION GSW_CT_FROM_PT(SA,PT)
C     !DESCRIPTION: \bv
C     *=============================================================*
C     | S/R  GSW_CT_FROM_PT
C     | o compute conservative temperature from potential
C     |   temperature (PT)  at reference level 0 dbar and absolute
C     |   salinity (SA)
C     | o this is a more or less shameless copy of the teos-10 code
C     |   available at http://www.teos-10.org
C     *=============================================================*
C     \ev

C     !USES:
      IMPLICIT NONE

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     SA :: Absolute Salinity                               (g/kg)
C     PT :: Potential Temperature                          (deg C)
      Real*8 sa, pt

C     !FUNCTIONS:
C     == Functions ==

C     !LOCAL VARIABLES:
C     == Local variables ==
      Real*8 pot_enthalpy, sfac
      Real*8 x2, x, y, cp0
CEOP

      sfac = 0.0248826675584615D0

      x2   = sfac*sa
      x    = 0.D0
      if (x2.gt.0.D0) x = sqrt(x2)
C     normalize for F03 and F08
      y    = pt*0.025D0

      pot_enthalpy =  61.01362420681071D0 +
     &     y*(168776.46138048015D0 +
     &     y*(-2735.2785605119625D0 + y*(2574.2164453821433D0 +
     &     y*(-1536.6644434977543D0 + y*(545.7340497931629D0 +
     &     (-50.91091728474331D0 - 18.30489878927802D0*y)*y))))) +
     &     x2*(268.5520265845071D0 + y*(-12019.028203559312D0 +
     &     y *(3734.858026725145D0 + y*(-2046.7671145057618D0 +
     &     y*(465.28655623826234D0 + (-0.6370820302376359D0 -
     &     10.650848542359153D0*y)*y)))) +
     &     x*(937.2099110620707D0 + y*(588.1802812170108D0 +
     &     y*(248.39476522971285D0 + (-3.871557904936333D0 -
     &     2.6268019854268356D0*y)*y)) +
     &     x*(-1687.914374187449D0 + x*(246.9598888781377D0 +
     &     x*(123.59576582457964D0 - 48.5891069025409D0*x)) +
     &     y*( 936.3206544460336D0 +
     &     y*(-942.7827304544439D0 + y*(369.4389437509002D0 +
     &     (-33.83664947895248D0 - 9.987880382780322D0*y)*y))))))

      cp0 = 3991.86795711963D0

      gsw_ct_from_pt = pot_enthalpy/cp0

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP
C     !ROUTINE: GSW_GIBBS_PT0_PT0
C     !INTERFACE:
      Real*8 FUNCTION GSW_GIBBS_PT0_PT0(SA,PT0)
C     !DESCRIPTION: \bv
C     *=============================================================*
C     | S/R GSW_GIBBS_PT0_PT0
C     | o helper routine that computes the specific Gibbs free
C     |   energy from potential temperature (PT) and absolute
C     |   salinity (SA) for pressure 0 dbar
C     | o this is a more or less shameless copy of the teos-10 code
C     |   available at http://www.teos-10.org
C     *=============================================================*
C     \ev

C     !USES:
      IMPLICIT NONE

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine arguments ==
C     SA :: Absolute Salinity                               (g/kg)
C     PT :: Potential Temperature at p = 0 dbar             (deg C)
      Real*8 sa, pt0

C     !FUNCTIONS:
C     == Functions ==

C     !LOCAL VARIABLES:
C     == Local variables ==
      Real*8 sfac, x2, x, y, g03, g08
CEOP

      sfac = 0.0248826675584615

      x2   = sfac*sa
      x    = 0.D0
      if (x2.gt.0.D0) x = sqrt(x2)
      y    = pt0*0.025D0

      g03 = -24715.571866078 +
     &     y*(4420.4472249096725 +
     &     y*(-1778.231237203896 +
     &     y*(1160.5182516851419 +
     &     y*(-569.531539542516  + y*128.13429152494615))))

      g08 = x2*(1760.062705994408  + x*(-86.1329351956084 +
     &     x*( -137.1145018408982  + y*(296.20061691375236 +
     &     y* (-205.67709290374563 + 49.9394019139016*y))) +
     &     y*(  -60.136422517125   + y*10.50720794170734)) +
     &     y*(-1351.605895580406   + y*(1097.1125373015109 +
     &     y*( -433.20648175062206 + 63.905091254154904*y))))

      gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625

      RETURN
      END


!dis    Forecast Systems Laboratory
!dis    NOAA/OAR/ERL/FSL
!dis    325 Broadway
!dis    Boulder, CO     80303
!dis
!dis    Forecast Research Division
!dis    Local Analysis and Prediction Branch
!dis    LAPS
!dis
!dis    This software and its documentation are in the public domain and
!dis    are furnished "as is."  The United States government, its
!dis    instrumentalities, officers, employees, and agents make no
!dis    warranty, express or implied, as to the usefulness of the software
!dis    and documentation for any purpose.  They assume no responsibility
!dis    (1) for the use of the software and documentation; or (2) to provide
!dis    technical support to users.
!dis
!dis    Permission to use, copy, modify, and distribute this software is
!dis    hereby granted, provided that the entire disclaimer notice appears
!dis    in all copies.  All modifications to this software must be clearly
!dis    documented, and are solely the responsibility of the agent making
!dis    the modifications.  If significant modifications or enhancements
!dis    are made to this software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis

SUBROUTINE GSI_BkObs

!==========================================================
!  This routine converts LAPS background and observations
!  to GSI format files.
!
!	Background  --> wrf_inout;
!	Observation --> bufr files, e.g., prepqc.
!
!  HISTORY:
! 	Creation: YUANFU XIE	3-2006
!	Modified: YUANFU XIE	10-2007 adding height to wrf.
!==========================================================

  USE LAPS_Parm

  IMPLICIT NONE

  ! Generate wrf_inout file: background.
  CALL GSI_Bkg(n(1),n(2),n(3),lat,lon, &
	      dxy,u_wind3d,v_wind3d)

  ! Generate bufr files for observation: prepqc.laps
  CALL GSI_Obs(i4time,asctime,lat,lon,n(1),n(2),n(3), &
	      nobs_point,obs_point,n_tobs,obs_temp,maxtobs)
  !CALL GSI_Obs_test

END SUBROUTINE GSI_BkObs

SUBROUTINE GSI_Bkg(imax,jmax,kmax,xlat,xlong, &
                  grid_spacing,u_laps_bkg,v_laps_bkg)

!==========================================================
!  This routine converts LAPS background into GSI wrf_inout
!  on the GSI mass coordinate.
!
!  HISTORY: MAR. 2006 by YUANFU XIE.
!==========================================================

  USE LAPS_Parm

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: imax,jmax,kmax  	! Dimensions
  REAL, INTENT(IN) :: xlat(imax,jmax),xlong(imax,jmax)
  REAL, INTENT(IN) :: grid_spacing
  REAL, INTENT(IN) :: u_laps_bkg(imax,jmax,kmax)   ! u bkg
  REAL, INTENT(IN) :: v_laps_bkg(imax,jmax,kmax)   ! v bkg

  ! Local variables:
  REAL, PARAMETER :: cp=1004.0, rc=287.0,t0=300.0 !273.15
  CHARACTER varname*3, fnm*9, hr*2, mins*2, jday*5, filename*150
  INTEGER :: i4time_sys,namelen
  INTEGER :: istatus,i,j,k
  REAL :: t_mass_bkg(imax,jmax,kmax)
  REAL :: sh_mass_bkg(imax,jmax,kmax)
  REAL :: geo_mass_bkg(imax,jmax,kmax)	! Geopotential
  REAL :: u_mass_bkg(imax,jmax,kmax),v_mass_bkg(imax,jmax,kmax)
  REAL :: dam(imax,jmax),pdam(imax,jmax)
  REAL :: znw(kmax),znu(kmax-1),mapfac_m(imax,jmax)

  ! Times:
  CHARACTER*19 :: times

  ! System time:
  CALL get_systime_all(i4time_sys,fnm,hr,mins,asctime,jday,istatus)
  IF (i4time .NE. i4time_sys) then
    PRINT*,'gsibkg: error: reading background in wrong time'
    STOP
  ENDIF

  ! Dry air mass in column (base state):
  CALL dryairmass(dam,pdam,imax,jmax,kmax,pressr1d, &
                  height3d,pressr3d,temptr3d)

  ! As default, a uniform mass vertical grid is used:
  ! eta = (p_d(k)-p_d(top))/(p_d(sfc)-p_d(top)):
  ! DO k=1,kmax
  !  znw(k) = 1.0-float(k-1)/float(kmax-1)
  ! ENDDO
  ! DO k=1,kmax-1
  !   znu(k) = 1.0-(float(k-1)+0.5)/float(kmax-1)
  ! ENDDO
  DO k=1,kmax
    znw(k) = (pressr1d(k)-pressr1d(kmax))/(pressr1d(1)-pressr1d(kmax))
  ENDDO
  DO k=1,kmax-1
    znu(k) = (0.5*(pressr1d(k)+pressr1d(k+1))-pressr1d(kmax))/(pressr1d(1)-pressr1d(kmax))
  ENDDO

  ! Map factor: use LAPS routine: get_sigma(lat,lon,fac,istatus)
  ! mapfac_m = 1.0		! Test
  DO j=1,jmax
    DO i=1,imax
      CALL get_sigma(xlat(i,j),xlong(i,j),mapfac_m(i,j),istatus)
    ENDDO
  ENDDO

  ! T background:
  ! Convert T to perturbation potential temperature (theta-t0):
  DO k=1,kmax
    temptr3d(1:imax,1:jmax,k) = temptr3d(1:imax,1:jmax,k)* &
                               (100000.0/pressr1d(k))**(rc/cp)-t0
  ENDDO
  CALL laps2mass(temptr3d,imax,jmax,kmax,pressr1d,dam,znw,4,0,t_mass_bkg)

  ! QVAPOR background:
  CALL laps2mass(sphumd3d,imax,jmax,kmax,pressr1d,dam,znw,4,0,sh_mass_bkg)

  ! U background:
  CALL laps2mass(u_laps_bkg,imax,jmax,kmax,pressr1d,dam,znw,4,0,u_mass_bkg)

  ! V background:
  CALL laps2mass(v_laps_bkg,imax,jmax,kmax,pressr1d,dam,znw,4,0,v_mass_bkg)

  ! Height background:
  CALL laps2mass(height3d,imax,jmax,kmax,pressr1d,dam,znw,4,0,geo_mass_bkg)
  ! Geopotential:
  geo_mass_bkg = 9.80665*geo_mass_bkg

  ! Write out state variable for post-processing:
  CALL get_directory('log',filename,namelen)
  filename = filename(1:namelen)//'fort.12'
  open(unit=12,file=filename(1:namelen+7),form='unformatted')
  WRITE(12) znw,pressr1d,dam,znu
  close(12)

  times(1:4) = asctime(8:11)
  times(5:5) = '-'
  SELECT CASE (asctime(4:6))
    CASE ('JAN')
	times(6:7) = '01'
    CASE ('FEB')
	times(6:7) = '02'
    CASE ('MAR')
	times(6:7) = '03'
    CASE ('APR')
	times(6:7) = '04'
    CASE ('MAY')
	times(6:7) = '05'
    CASE ('JUN')
	times(6:7) = '06'
    CASE ('JUL')
	times(6:7) = '07'
    CASE ('AUG')
	times(6:7) = '08'
    CASE ('SEP')
	times(6:7) = '09'
    CASE ('OCT')
	times(6:7) = '10'
    CASE ('NOV')
	times(6:7) = '11'
    CASE ('DEC')
	times(6:7) = '12'
    CASE default
	PRINT*,'GSIb: error: invalid month: ',asctime(4:6)
	STOP
  END SELECT
  times(8:8) = '-'
  times(9:10) = asctime(1:2)
  times(11:11) = '_'
  times(12:13) = asctime(13:14)
  times(14:14) = ':'
  times(15:16) = asctime(15:16)
  times(17:19) = ':00'

  ! Write the variables into a wrf_inout netcdf file:
  CALL wrfbkgout(times,imax,jmax,kmax,pressr1d(kmax), &
     		 znu,znw,grid_spacing,mapfac_m,xlat, &
     		 xlong,dam,pdam,t_mass_bkg,geo_mass_bkg, &
     		 sh_mass_bkg,u_mass_bkg,v_mass_bkg,topo)

END SUBROUTINE GSI_Bkg

SUBROUTINE GSI_Obs(i4time,asctime,lat,lon,imax,jmax,kmax, &
     		  nobs,obs_point,n_tobs,obs_temp,maxtobs)

!==========================================================
!  This routine generates a bufr format data file for GSI.
!
!  HISTORY: MAR. 2006 by YUANFU XIE.
!==========================================================

  ! GSIobs reads LAPS ingest observation data (obs_point)
  ! and converts it into prepbufr format saved in prepqc.laps
  ! so that GSI 3DVAR can use.

  IMPLICIT NONE

  INCLUDE 'barnesob.inc'

  CHARACTER*16, intent(in) :: asctime
  INTEGER, intent(in) :: i4time,nobs,imax,jmax,kmax
  REAL, intent(in) :: lat(imax,jmax),lon(imax,jmax)
  TYPE (barnesob) :: obs_point(*)
  INTEGER, INTENT(IN) :: n_tobs,maxtobs
  REAL, INTENT(IN) :: obs_temp(maxtobs,12)

  INTEGER, parameter :: MXMN = 8
  INTEGER, parameter :: MXLV = 255
  REAL*8, parameter :: missing = 10.0e10
  REAL :: rlat,rlon,ztopsa,pres_3d(imax,jmax,kmax),p
  REAL*8 :: r8arr ( MXMN, MXLV ),rval

  INTEGER, parameter :: MXBF = 16000
  INTEGER :: ibfmsg ( MXBF/4 )

  INTEGER :: yearofreport,mnthofreport,daysofreport
  INTEGER :: hourofreport,istatus
  INTEGER :: idate,nlv,nlvst,jj,libf,ierr,iobs,zero

  CHARACTER	:: cval*8
  EQUIVALENCE ( cval, rval )

  ! Static access:
  CHARACTER :: dirstc*256,dir*200
  INTEGER :: dirlen

  ! Ingest obs:
  PRINT*,'Total wind obs into GSI: ',nobs
  PRINT*,'Total temp obs into GSI: ',n_tobs

  ! Read background total pressure 3d field:
  CALL get_pres_3d(i4time,imax,jmax,kmax,pres_3d,istatus)

  ! Open the BUFR messages file.
  OPEN( UNIT = 11, FILE = 'prepqc.laps', form='unformatted' )

  ! Open the BUFR tables file.
  CALL get_directory('static',dirstc,dirlen)
  dir = dirstc(1:dirlen)//'prepobs_prep.bufrtable'
  OPEN( UNIT = 12, FILE = dir(1:dirlen+23) )

  ! Associate the tables file with the messages file, and
  ! identify the latter to the BUFRLIB software.

  CALL OPENBF  ( 11, 'OUT', 12 )

  ! Report date:
  yearofreport = 2005
  mnthofreport = 11
  daysofreport = 21
  hourofreport = 15
  yearofreport = 2006
  mnthofreport = 2
  daysofreport = 7
  hourofreport = 14
  zero = ichar('0')
  yearofreport = (ichar(asctime(8:8))-zero)*1000+ &
     		 (ichar(asctime(9:9))-zero)*100+ &
     		 (ichar(asctime(10:10))-zero)*10+ &
     		 (ichar(asctime(11:11))-zero)
  SELECT CASE (asctime(4:6))
    CASE ('JAN')
	mnthofreport = 1
    CASE ('FEB')
	mnthofreport = 2
    CASE ('MAR')
	mnthofreport = 3
    CASE ('APR')
	mnthofreport = 4
    CASE ('MAY')
	mnthofreport = 5
    CASE ('JUN')
	mnthofreport = 6
    CASE ('JUL')
	mnthofreport = 7
    CASE ('AUG')
	mnthofreport = 8
    CASE ('SEP')
	mnthofreport = 9
    CASE ('OCT')
	mnthofreport = 10
    CASE ('NOV')
	mnthofreport = 11
    CASE ('DEC')
	mnthofreport = 12
    CASE default
	PRINT*,'wrfbkgout: error: invalid month: ',asctime(4:6)
	STOP
  END SELECT
  daysofreport = (ichar(asctime(1:1))-zero)*10+ &
     		  ichar(asctime(2:2))-zero
  hourofreport = (ichar(asctime(13:13))-zero)*10+ &
     		  ichar(asctime(14:14))-zero

  ! For every wind observation data:
  DO iobs=1,nobs

    idate = ( ( yearofreport ) * 1000000 ) + 	&
     	    ( ( mnthofreport ) * 10000 )  +	&
            ( ( daysofreport ) * 100 ) +	&
     	    (   hourofreport       )

    ! Open a rawinsonde BUFR message in order to store the new
    ! data subset (i.e. report).

    CALL OPENMB  ( 11, 'ADPUPA', idate )

    ! Store the report date-time within the data subset.

    r8arr (1,1) = ( yearofreport )
    r8arr (2,1) = ( mnthofreport )
    r8arr (3,1) = ( daysofreport )
    r8arr (4,1) = ( hourofreport )

    CALL UFBSEQ  ( 11, r8arr, MXMN, 1, nlv, 'UARTM' )

    !   Store the station identification information within the
    !   data subset.
    !   cval = ( station ID, e.g. '72403', 'DBBH', etc.)
    cval = '72403'

    ! Convert to lat/lon:
    CALL rlapsgrid_to_latlon(obs_point(iobs)%ri,obs_point(iobs)%rj, &
                             lat,lon,imax,jmax,rlat,rlon,ierr)

    r8arr (1,1) = rval
    r8arr (3,1) = rlat		!( station latitude )
    r8arr (2,1) = rlon		!( station longitude )
    r8arr (4,1) = (obs_point(iobs)%i4time-i4time)/3600.0 !( obs time )
    r8arr (5,1) = 210.0		!( prepbufr report type )
    r8arr (6,1) = obs_point(iobs)%elev!( station elevation )

    CALL UFBINT  ( 11, r8arr, MXMN, 1, nlv, &
    		  'SID XOB YOB DHR TYP ELV ')

    ! Store the level data within the data subset.

    ! For LAPS data ingest, treat obs individually for now:
    nlvst = 1 	!( number of data levels to be stored)

    DO jj = 1, nlvst

      ! Use trilinear_laps.f to interpolate pressure value at ri,rj,rk:
      CALL trilinear_laps(obs_point(iobs)%ri, &
    			  obs_point(iobs)%rj, &
     			  obs_point(iobs)%rk,imax,jmax,kmax, &
     			  pres_3d,p)
      r8arr(1,jj) = p/100.0	! (in mb)

      ! r8arr (1,jj) = ztopsa(obs_point(iobs)%elev)

      !899.0 !missing !( pressure, in mb, for level jj )
      r8arr (2,jj) = missing !( SPECIFIC HUMIDITY OBSERVATION)
      r8arr (3,jj) = missing !( temperature in C for level jj )
      r8arr (4,jj) = missing !( height, in M, for level jj )
      r8arr (5,jj) = obs_point(iobs)%value(1) !( U M/S, for level jj )
      r8arr (6,jj) = obs_point(iobs)%value(2) !( V M/S, for level jj )
      r8arr (7,jj) = missing  !( Precipitable water mm, for level jj )
      r8arr (8,jj) = missing

    ENDDO

    CALL UFBINT ( 11, r8arr, MXMN, nlvst, nlv, &
     		'POB QOB TOB ZOB UOB VOB PWO CAT' )
    r8arr = 0.0
    CALL UFBINT ( 11, r8arr, MXMN, nlvst, nlv, &
                'PQM QQM TQM ZQM WQM NUL PWQ' )

    ! ( store any other available values in a similar manner )
    ! Once all data values have been stored for this data subset,
    ! we are now ready to store the data subset into the message.

    CALL WRITSA  ( 11, ibfmsg, libf )

  ENDDO

  ! For every temperature observation data:
  DO iobs=1,n_tobs

    idate = ( ( yearofreport ) * 1000000 ) + 	&
     	    ( ( mnthofreport ) * 10000 )  +	&
            ( ( daysofreport ) * 100 ) +	&
     	    (   hourofreport       )

    ! Open a rawinsonde BUFR message in order to store the new
    ! data subset (i.e. report).

    CALL OPENMB  ( 11, 'ADPUPA', idate )

    ! Store the report date-time within the data subset.

    r8arr (1,1) = ( yearofreport )
    r8arr (2,1) = ( mnthofreport )
    r8arr (3,1) = ( daysofreport )
    r8arr (4,1) = ( hourofreport )

    CALL UFBSEQ  ( 11, r8arr, MXMN, 1, nlv, 'UARTM' )

    !   Store the station identification information within the
    !   data subset.
    !   cval = ( station ID, e.g. '72403', 'DBBH', etc.)
    cval = '72403'

    ! Convert to lat/lon:
    CALL rlapsgrid_to_latlon(obs_temp(iobs,1),obs_temp(iobs,2), &
                             lat,lon,imax,jmax,rlat,rlon,ierr)

    r8arr (1,1) = rval
    r8arr (3,1) = rlat		!( station latitude )
    r8arr (2,1) = rlon		!( station longitude )
    r8arr (4,1) = 0.0 		!( obs time; Enhance this later)
    r8arr (5,1) = 132.0		!( prepbufr report type )
    r8arr (6,1) = missing !( station elevation )

    CALL UFBINT  ( 11, r8arr, MXMN, 1, nlv, &
    		  'SID XOB YOB DHR TYP ELV ')

    ! Store the level data within the data subset.

    ! For LAPS data ingest, treat obs individually for now:
    nlvst = 1 	!( number of data levels to be stored)

    DO jj = 1, nlvst

      ! Use trilinear_laps.f to interpolate pressure value at ri,rj,rk:
      CALL trilinear_laps(obs_temp(iobs,1), &
    			  obs_temp(iobs,2), &
     			  obs_temp(iobs,3),imax,jmax,kmax, &
     			  pres_3d,p)
      r8arr(1,jj) = p/100.0	! (in mb)

      ! r8arr (1,jj) = ztopsa(obs_point(iobs)%elev)

      !899.0 !missing !( pressure, in mb, for level jj )
      r8arr (2,jj) = missing !( SPECIFIC HUMIDITY OBSERVATION)
      r8arr (3,jj) = obs_temp(iobs,7) !( temperature in C for level jj )
      r8arr (4,jj) = missing !( height, in M, for level jj )
      r8arr (5,jj) = missing !( U M/S, for level jj )
      r8arr (6,jj) = missing !( V M/S, for level jj )
      r8arr (7,jj) = missing  !( Precipitable water mm, for level jj )
      r8arr (8,jj) = missing

    ENDDO

    CALL UFBINT ( 11, r8arr, MXMN, nlvst, nlv, &
     		'POB QOB TOB ZOB UOB VOB PWO CAT' )
    r8arr = 0.0
    CALL UFBINT ( 11, r8arr, MXMN, nlvst, nlv, &
                'PQM QQM TQM ZQM WQM NUL PWQ' )

    ! ( store any other available values in a similar manner )
    ! Once all data values have been stored for this data subset,
    ! we are now ready to store the data subset into the message.

    CALL WRITSA  ( 11, ibfmsg, libf )

  ENDDO

  ! Forcibly flush the last BUFR message, if any, from the
  ! BUFRLIB software.

  CALL WRITSA  ( -11, ibfmsg, libf )
  CALL CLOSBF  ( 11 )

  PRINT*,'Wind data converted: ',nobs
  PRINT*,'Temp data converted: ',n_tobs

END SUBROUTINE GSI_Obs


      PROGRAM BEM
C ---------------------------------------------------------------------------
C
C ---------------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
      INCLUDE 'max_params.inc'
C
      INTEGER(KIND=IK) NSD               ! nr. of subdomains
      INTEGER(KIND=IK) NNW               ! nr. of networks
      INTEGER(KIND=IK) NGP               ! nr. of grid points
      INTEGER(KIND=IK) NAE               ! nr. of array elements
      INTEGER(KIND=IK) NNW_SD (NSD_MAX)  ! nr. of networks per subdomain
      INTEGER(KIND=IK) NGP_SD (NSD_MAX)  ! nr. of grid points per subd.
      INTEGER(KIND=IK) NGP_NW (NNW_MAX)  ! nr. of grid points per netw.
C
      CALL INIT
     &     (NSD, NNW, NGP, NAE, NNW_SD, NGP_SD, NGP_NW)
C
      CALL MAIN
     &     (NSD, NNW, NGP, NAE, NNW_SD, NGP_SD, NGP_NW)
C
      CALL DONE
     &     (NSD, NNW_SD)
C
      END