Back to home page

MITgcm

 
 

    


File indexing completed on 2025-02-02 06:11:05 UTC

view on githubraw file Latest commit 701e10a9 on 2025-02-01 19:15:20 UTC
6d54cf9ca1 Ed H*0001 #include "EXF_OPTIONS.h"
3a255f48df Gael*0002 #ifdef ALLOW_AUTODIFF
                0003 # include "AUTODIFF_OPTIONS.h"
                0004 #endif
7f861c1808 Patr*0005 
9fe4461eea Patr*0006 CBOI
                0007 C
                0008 C !TITLE: EXTERNAL FORCING
14a20b48a3 Jean*0009 C !AUTHORS: mitgcm developers ( mitgcm-support@mitgcm.org )
9fe4461eea Patr*0010 C !AFFILIATION: Massachussetts Institute of Technology
                0011 C !DATE:
                0012 C !INTRODUCTION: External forcing package
14a20b48a3 Jean*0013 C \bv
                0014 C * The external forcing package, in conjunction with the
                0015 C   calendar package (cal), enables the handling of realistic forcing
                0016 C   fields of differing temporal forcing patterns.
                0017 C * It comprises climatological restoring and relaxation
                0018 C * Bulk formulae are implemented to convert atmospheric fields
                0019 C   to surface fluxes.
                0020 C * An interpolation routine provides on-the-fly interpolation of
                0021 C   forcing fields an arbitrary grid onto the model grid.
                0022 C * A list of EXF variables and units is in EXF_FIELDS.h
                0023 C
9fe4461eea Patr*0024 C     !CALLING SEQUENCE:
14a20b48a3 Jean*0025 C ...
423768d890 Jean*0026 C  EXF_GETFORCING (TOP LEVEL ROUTINE)
14a20b48a3 Jean*0027 C  |
423768d890 Jean*0028 C  |-- EXF_GETCLIM (get climatological fields used e.g. for relax.)
14a20b48a3 Jean*0029 C  |   |--- exf_set_climtemp (relax. to 3-D temperature field)
                0030 C  |   |--- exf_set_climsalt (relax. to 3-D salinity field)
                0031 C  |   |--- exf_set_climsst  (relax. to 2-D SST field)
                0032 C  |   |--- exf_set_climsss  (relax. to 2-D SSS field)
                0033 C  |   o
                0034 C  |
423768d890 Jean*0035 C  |-- EXF_GETFFIELDS <- this one does almost everything
14a20b48a3 Jean*0036 C  |   |   1. reads in fields, either flux or atmos. state,
                0037 C  |   |      depending on CPP options (for each variable two fields
                0038 C  |   |      consecutive in time are read in and interpolated onto
                0039 C  |   |      current time step).
                0040 C  |   |   2. If forcing is atmos. state and control is atmos. state,
                0041 C  |   |      then the control variable anomalies are read here
                0042 C  |   |          * ctrl_getatemp
                0043 C  |   |          * ctrl_getaqh
                0044 C  |   |          * ctrl_getuwind
                0045 C  |   |          * ctrl_getvwind
                0046 C  |   |      If forcing and control are fluxes, then
                0047 C  |   |      controls are added later.
                0048 C  |   o
                0049 C  |
423768d890 Jean*0050 C  |-- EXF_CHECK_RANGE
                0051 C  |   |   Check whether read fields are within assumed range
                0052 C  |   |   (may capture mismatches in units)
14a20b48a3 Jean*0053 C  |   o
                0054 C  |
423768d890 Jean*0055 C  |-- EXF_RADIATION
                0056 C  |   |   Compute net or downwelling radiative fluxes via
                0057 C  |   |   Stefan-Boltzmann law in case only one is known.
                0058 C  |-- EXF_WIND
                0059 C  |   |   Compute air-sea wind-stress from winds (or the other way)
                0060 C  |-- EXF_BULKFORMULAE
                0061 C  |   |   Compute air-sea buoyancy fluxes from atmospheric
                0062 C  |   |   state following Large and Pond, JPO, 1981/82
14a20b48a3 Jean*0063 C  |   o
                0064 C  |
                0065 C  |-- < add time-mean river runoff here, if available >
                0066 C  |
                0067 C  |-- < update tile edges here >
                0068 C  |
423768d890 Jean*0069 C  |-- EXF_GETSURFACEFLUXES
                0070 C  |   |   If forcing and control are fluxes, then
                0071 C  |   |   control vector anomalies are added here.
                0072 C  |   |--- ctrl_get_gen
14a20b48a3 Jean*0073 C  |   o
                0074 C  |
                0075 C  |-- < treatment of hflux w.r.t. swflux >
                0076 C  |
423768d890 Jean*0077 C  |-- EXF_DIAGNOSTICS_FILL
                0078 C  |   |   Do EXF-related diagnostics output here.
                0079 C  |-- EXF_MONITOR
                0080 C  |   |   Monitor EXF-forcing fields
14a20b48a3 Jean*0081 C  |   o
                0082 C  |
423768d890 Jean*0083 C  |-- EXF_MAPFIELDS
                0084 C  |   |   Forcing fields from exf package are mapped onto
                0085 C  |   |   mitgcm forcing arrays.
                0086 C  |   |   Mapping enables a runtime rescaling of fields
14a20b48a3 Jean*0087 C  |   o
                0088 C
                0089 C \ev
9fe4461eea Patr*0090 CEOI
                0091 
                0092 CBOP
14a20b48a3 Jean*0093 C     !ROUTINE: EXF_GETFORCING
9fe4461eea Patr*0094 C     !INTERFACE:
14a20b48a3 Jean*0095       SUBROUTINE EXF_GETFORCING( myTime, myIter, myThid )
9fe4461eea Patr*0096 
                0097 C     !DESCRIPTION: \bv
14a20b48a3 Jean*0098 C     *=================================================================
                0099 C     | SUBROUTINE EXF_GETFORCING
                0100 C     *=================================================================
                0101 C     o Get the forcing fields for the current time step. The switches
                0102 C       for the inclusion of the individual forcing components have to
                0103 C       be set in EXF_OPTIONS.h (or ECCO_CPPOPTIONS.h).
                0104 C       A note on surface fluxes:
                0105 C       The MITgcm-UV vertical coordinate z is positive upward.
                0106 C       This implies that a positive flux is out of the ocean
                0107 C       model. However, the wind stress forcing is not treated
                0108 C       this way. A positive zonal wind stress accelerates the
                0109 C       model ocean towards the east.
                0110 C       started: eckert@mit.edu, heimbach@mit.edu, ralf@ocean.mit.edu
                0111 C       mods for pkg/seaice: menemenlis@jpl.nasa.gov 20-Dec-2002
                0112 C     *=================================================================
                0113 C     | SUBROUTINE EXF_GETFORCING
                0114 C     *=================================================================
9fe4461eea Patr*0115 C     \ev
7f861c1808 Patr*0116 
9fe4461eea Patr*0117 C     !USES:
14a20b48a3 Jean*0118       IMPLICIT NONE
7f861c1808 Patr*0119 
14a20b48a3 Jean*0120 C     == global variables ==
bdec91d862 Patr*0121 #include "EEPARAMS.h"
                0122 #include "SIZE.h"
                0123 #include "PARAMS.h"
                0124 #include "GRID.h"
                0125 
082e18c36c Jean*0126 #include "EXF_PARAM.h"
                0127 #include "EXF_FIELDS.h"
                0128 #include "EXF_CONSTANTS.h"
a0a3896567 Patr*0129 #ifdef ALLOW_AUTODIFF_TAMC
                0130 # include "tamc.h"
                0131 #endif
b4daa24319 Shre*0132 #ifdef ALLOW_TAPENADE
                0133 # include "EXF_INTERP_SIZE.h"
                0134 # include "EXF_INTERP_PARAM.h"
                0135 #endif /* ALLOW_TAPENADE */
701e10a905 Mart*0136 #if ( defined ALLOW_DOWNWARD_RADIATION ) || \
                0137       ( defined ALLOW_ATM_TEMP && defined ALLOW_BULKFORMULAE )
                0138 # include "FFIELDS.h"
                0139 # include "DYNVARS.h"
                0140 #endif
bdec91d862 Patr*0141 
9fe4461eea Patr*0142 C     !INPUT/OUTPUT PARAMETERS:
14a20b48a3 Jean*0143 C     == routine arguments ==
                0144       _RL     myTime
                0145       INTEGER myIter
                0146       INTEGER myThid
7f861c1808 Patr*0147 
9fe4461eea Patr*0148 C     !LOCAL VARIABLES:
14a20b48a3 Jean*0149 C     == local variables ==
                0150       INTEGER bi,bj
0320e25227 Mart*0151       INTEGER i,j,ks
701e10a905 Mart*0152 #if ( defined ALLOW_DOWNWARD_RADIATION ) || \
                0153       ( defined ALLOW_ATM_TEMP && defined ALLOW_BULKFORMULAE )
                0154       INTEGER kl
                0155       _RL deltaSST
                0156 C     exf_Tsf :: local copy of global field gcmSST or extrapolated
                0157 C                surface temperature (in deg Celsius)
                0158       _RL exf_Tsf        (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0159 #endif
14a20b48a3 Jean*0160 C     == end of interface ==
9fe4461eea Patr*0161 CEOP
7f861c1808 Patr*0162 
701e10a905 Mart*0163       ks = 1
                0164       IF ( usingPCoords ) ks = Nr
                0165 #if ( defined ALLOW_DOWNWARD_RADIATION ) || \
                0166       ( defined ALLOW_ATM_TEMP && defined ALLOW_BULKFORMULAE )
                0167 C     Compute the surface temperature either as copy of the global
                0168 C     variable gcmSST or by extrapolation to the actual surface
                0169 C     (W-point).
                0170       kl = 2
                0171       IF ( usingPCoords ) kl = Nr-1
                0172       DO bj = myByLo(myThid),myByHi(myThid)
                0173        DO bi = myBxLo(myThid),myBxHi(myThid)
                0174         IF ( Nr.GE.2 .AND. sstExtrapol.GT.0. _d 0 ) THEN
                0175          DO j = 1-OLy,sNy+OLy
                0176           DO i = 1-OLx,sNx+OLx
                0177            deltaSST = sstExtrapol
                0178      &          *( theta(i,j,ks,bi,bj)-theta(i,j,kl,bi,bj) )
                0179      &          *  maskC(i,j,kl,bi,bj)
                0180            exf_Tsf(i,j,bi,bj) = gcmSST(i,j,bi,bj) + cen2kel
                0181      &          + MAX( deltaSST, 0. _d 0 )
                0182           ENDDO
                0183          ENDDO
                0184         ELSE
                0185          DO j = 1-OLy,sNy+OLy
                0186           DO i = 1-OLx,sNx+OLx
                0187            exf_Tsf(i,j,bi,bj) = gcmSST(i,j,bi,bj) + cen2kel
                0188           ENDDO
                0189          ENDDO
                0190         ENDIF
                0191        ENDDO
                0192       ENDDO
                0193 #endif
                0194 
14a20b48a3 Jean*0195 C     Get values of climatological fields.
423768d890 Jean*0196       CALL EXF_GETCLIM( myTime, myIter, myThid )
7f861c1808 Patr*0197 
14a20b48a3 Jean*0198 C     Get the surface forcing fields.
423768d890 Jean*0199       CALL EXF_GETFFIELDS( myTime, myIter, myThid )
358649780a Gael*0200       IF ( .NOT.useAtmWind ) THEN
423768d890 Jean*0201        IF ( stressIsOnCgrid .AND. ustressfile.NE.' '
                0202      &                      .AND. vstressfile.NE.' ' )
9c3e24f78c Jean*0203      &  CALL EXCH_UV_XY_RL( ustress, vstress, .TRUE., myThid )
358649780a Gael*0204       ENDIF
7f861c1808 Patr*0205 
98238efc8b Patr*0206 #ifdef ALLOW_AUTODIFF_TAMC
9c41af81f6 Timo*0207 C     Store fields after reading them so that we do not need to save
                0208 C     their 0/1 levels to comlev1. Not all fields are required here (in
                0209 C     most cases only u/vwind or u/vstress, aqh, atemp, precip,
                0210 C     snowprecip, runoff), but we have directives for all potential
                0211 C     candidates here.
                0212 CADJ STORE ustress      = comlev1, key=ikey_dynamics, kind=isbyte
                0213 CADJ STORE vstress      = comlev1, key=ikey_dynamics, kind=isbyte
                0214 CADJ STORE uwind        = comlev1, key=ikey_dynamics, kind=isbyte
                0215 CADJ STORE vwind        = comlev1, key=ikey_dynamics, kind=isbyte
                0216 CADJ STORE wspeed       = comlev1, key=ikey_dynamics, kind=isbyte
                0217 # ifdef ALLOW_ATM_TEMP
                0218 CADJ STORE aqh        = comlev1, key=ikey_dynamics, kind=isbyte
                0219 CADJ STORE atemp      = comlev1, key=ikey_dynamics, kind=isbyte
                0220 CADJ STORE precip     = comlev1, key=ikey_dynamics, kind=isbyte
                0221 CADJ STORE lwflux     = comlev1, key=ikey_dynamics, kind=isbyte
                0222 CADJ STORE swflux     = comlev1, key=ikey_dynamics, kind=isbyte
                0223 CADJ STORE snowprecip = comlev1, key=ikey_dynamics, kind=isbyte
                0224 #  ifdef ALLOW_READ_TURBFLUXES
                0225 CADJ STORE hs         = comlev1, key=ikey_dynamics, kind=isbyte
                0226 CADJ STORE hl         = comlev1, key=ikey_dynamics, kind=isbyte
                0227 #  endif /* ALLOW_READ_TURBFLUXES */
                0228 #  ifdef EXF_READ_EVAP
                0229 CADJ STORE evap       = comlev1, key=ikey_dynamics, kind=isbyte
                0230 #  endif /* EXF_READ_EVAP */
                0231 #  ifdef ALLOW_DOWNWARD_RADIATION
                0232 CADJ STORE swdown     = comlev1, key=ikey_dynamics, kind=isbyte
                0233 CADJ STORE lwdown     = comlev1, key=ikey_dynamics, kind=isbyte
                0234 #  endif
                0235 # else /* ALLOW_ATM_TEMP undef */
                0236 #  ifdef SHORTWAVE_HEATING
                0237 CADJ STORE swflux     = comlev1, key=ikey_dynamics, kind=isbyte
                0238 #  endif
                0239 # endif /* ALLOW_ATM_TEMP */
                0240 # ifdef ATMOSPHERIC_LOADING
                0241 CADJ STORE apressure  = comlev1, key=ikey_dynamics, kind=isbyte
                0242 # endif
                0243 # ifdef ALLOW_RUNOFF
                0244 CADJ STORE runoff     = comlev1, key=ikey_dynamics, kind=isbyte
                0245 # endif
                0246 # ifdef ALLOW_SALTFLX
                0247 CADJ STORE saltflx    = comlev1, key=ikey_dynamics, kind=isbyte
                0248 # endif
                0249 # ifdef EXF_SEAICE_FRACTION
                0250 CADJ STORE areamask   = comlev1, key=ikey_dynamics, kind=isbyte
                0251 # endif
                0252 #endif /* ALLOW_AUTODIFF_TAMC */
                0253 
5d96c49326 Jean*0254 #ifdef ALLOW_AUTODIFF
14a20b48a3 Jean*0255 # ifdef ALLOW_AUTODIFF_MONITOR
98238efc8b Patr*0256         CALL EXF_ADJOINT_SNAPSHOTS( 2, myTime, myIter, myThid )
                0257 # endif
5d96c49326 Jean*0258 #endif /* ALLOW_AUTODIFF */
98238efc8b Patr*0259 
423768d890 Jean*0260 #ifdef ALLOW_DOWNWARD_RADIATION
14a20b48a3 Jean*0261 C     Set radiative fluxes
701e10a905 Mart*0262       CALL EXF_RADIATION( exf_Tsf, myTime, myIter, myThid )
423768d890 Jean*0263 #endif
3752238fd8 Patr*0264 
14a20b48a3 Jean*0265 C     Set wind fields
423768d890 Jean*0266       CALL EXF_WIND( myTime, myIter, myThid )
                0267 
                0268 #ifdef ALLOW_ATM_TEMP
                0269 # ifdef ALLOW_BULKFORMULAE
                0270 #  ifdef ALLOW_AUTODIFF_TAMC
9c41af81f6 Timo*0271 C     Here we probably only need to store uwind, vwind, wstress but we
                0272 C     keep the other fields for the paranoid AD-modeller
358649780a Gael*0273 CADJ STORE uwind        = comlev1, key=ikey_dynamics, kind=isbyte
                0274 CADJ STORE vwind        = comlev1, key=ikey_dynamics, kind=isbyte
                0275 CADJ STORE wspeed       = comlev1, key=ikey_dynamics, kind=isbyte
9c41af81f6 Timo*0276 CADJ STORE ustress      = comlev1, key=ikey_dynamics, kind=isbyte
                0277 CADJ STORE vstress      = comlev1, key=ikey_dynamics, kind=isbyte
                0278 CADJ STORE wstress      = comlev1, key=ikey_dynamics, kind=isbyte
423768d890 Jean*0279 #  endif
14a20b48a3 Jean*0280 C     Compute turbulent fluxes (and surface stress) from bulk formulae
701e10a905 Mart*0281       CALL EXF_BULKFORMULAE( exf_Tsf, myTime, myIter, myThid )
9c41af81f6 Timo*0282 #  ifdef ALLOW_AUTODIFF_TAMC
                0283 CADJ STORE evap         = comlev1, key=ikey_dynamics, kind=isbyte
                0284 #  endif
423768d890 Jean*0285 # endif /* ALLOW_BULKFORMULAE */
                0286 #endif /* ALLOW_ATM_TEMP */
bdec91d862 Patr*0287 
14a20b48a3 Jean*0288       DO bj = myByLo(myThid), myByHi(myThid)
                0289        DO bi = myBxLo(myThid), myBxHi(myThid)
423768d890 Jean*0290 
                0291 #ifdef ALLOW_ATM_TEMP
                0292 C     compute hflux & sflux from multiple components
0320e25227 Mart*0293         DO j = 1,sNy
                0294          DO i = 1,sNx
                0295 C     Net surface heat flux.
                0296           hflux(i,j,bi,bj) =
                0297      &         - hs(i,j,bi,bj)
                0298      &         - hl(i,j,bi,bj)
                0299      &         + lwflux(i,j,bi,bj)
3752238fd8 Patr*0300 #ifndef SHORTWAVE_HEATING
0320e25227 Mart*0301      &         + swflux(i,j,bi,bj)
3752238fd8 Patr*0302 #endif
14a20b48a3 Jean*0303 C             fresh-water flux from Precipitation and Evaporation.
0320e25227 Mart*0304           sflux(i,j,bi,bj) = evap(i,j,bi,bj) - precip(i,j,bi,bj)
                0305          ENDDO
                0306         ENDDO
3752238fd8 Patr*0307 #endif /* ALLOW_ATM_TEMP */
423768d890 Jean*0308 
                0309 C     Apply runoff, masks and exchanges
0320e25227 Mart*0310         DO j = 1,sNy
                0311          DO i = 1,sNx
bdec91d862 Patr*0312 #ifdef ALLOW_RUNOFF
0320e25227 Mart*0313           sflux(i,j,bi,bj) = sflux(i,j,bi,bj) - runoff(i,j,bi,bj)
bdec91d862 Patr*0314 #endif
0320e25227 Mart*0315           hflux(i,j,bi,bj) = hflux(i,j,bi,bj)*maskC(i,j,ks,bi,bj)
                0316           sflux(i,j,bi,bj) = sflux(i,j,bi,bj)*maskC(i,j,ks,bi,bj)
                0317          ENDDO
14a20b48a3 Jean*0318         ENDDO
0320e25227 Mart*0319 
                0320        ENDDO
14a20b48a3 Jean*0321       ENDDO
bdec91d862 Patr*0322 
14a20b48a3 Jean*0323 C     Update the tile edges: needed for some EXF fields involved in horizontal
                0324 C     averaging, e.g., wind-stress; fields used by main model or other pkgs
                0325 C     are exchanged in EXF_MAPFIELDS.
                0326 c     _EXCH_XY_RL(hflux,   myThid)
                0327 c     _EXCH_XY_RL(sflux,   myThid)
9c3e24f78c Jean*0328       IF ( stressIsOnCgrid ) THEN
0320e25227 Mart*0329        CALL EXCH_UV_XY_RL( ustress, vstress, .TRUE., myThid )
9c3e24f78c Jean*0330       ELSE
0320e25227 Mart*0331        CALL EXCH_UV_AGRID_3D_RL(ustress, vstress, .TRUE., 1, myThid)
9c3e24f78c Jean*0332       ENDIF
bdec91d862 Patr*0333 #ifdef SHORTWAVE_HEATING
14a20b48a3 Jean*0334 c     _EXCH_XY_RL(swflux, myThid)
bdec91d862 Patr*0335 #endif
                0336 #ifdef ATMOSPHERIC_LOADING
14a20b48a3 Jean*0337 c     _EXCH_XY_RL(apressure, myThid)
bdec91d862 Patr*0338 #endif
24da7525ba Jean*0339 #ifdef EXF_SEAICE_FRACTION
14a20b48a3 Jean*0340 c     _EXCH_XY_RL(areamask, myThid)
8f277f2728 Gael*0341 #endif
bdec91d862 Patr*0342 
14a20b48a3 Jean*0343 C     Get values of the surface flux anomalies.
423768d890 Jean*0344       CALL EXF_GETSURFACEFLUXES( myTime, myIter, myThid )
7f861c1808 Patr*0345 
14a20b48a3 Jean*0346       IF ( useExfCheckRange .AND.
9f46642c85 Jean*0347      &     ( myIter.EQ.nIter0 .OR. exf_debugLev.GE.debLevC ) ) THEN
0320e25227 Mart*0348        CALL EXF_CHECK_RANGE( myTime, myIter, myThid )
14a20b48a3 Jean*0349       ENDIF
d7ee8fe52e Patr*0350 
423768d890 Jean*0351 #ifdef ALLOW_AUTODIFF
14a20b48a3 Jean*0352 # ifdef ALLOW_AUTODIFF_MONITOR
0320e25227 Mart*0353       CALL EXF_ADJOINT_SNAPSHOTS( 1, myTime, myIter, myThid )
98238efc8b Patr*0354 # endif
423768d890 Jean*0355 #endif /* ALLOW_AUTODIFF */
98238efc8b Patr*0356 
da754645e6 Jean*0357 #ifdef ALLOW_ATM_TEMP
                0358 # ifdef SHORTWAVE_HEATING
14a20b48a3 Jean*0359 C     Treatment of qnet
da754645e6 Jean*0360 C     The location of the summation of Qnet in exf_mapfields is unfortunate:
14a20b48a3 Jean*0361 C     For backward compatibility issues we want it to happen after
                0362 C     applying control variables, but before exf_diagnostics_fill.
                0363 C     Therefore, we DO it exactly here:
                0364       DO bj = myByLo(myThid), myByHi(myThid)
                0365        DO bi = myBxLo(myThid), myBxHi(myThid)
0320e25227 Mart*0366         DO j = 1-OLy,sNy+OLy
                0367          DO i = 1-OLx,sNx+OLx
92db8eb413 Patr*0368           hflux(i,j,bi,bj) = hflux(i,j,bi,bj) + swflux(i,j,bi,bj)
14a20b48a3 Jean*0369          ENDDO
                0370         ENDDO
                0371        ENDDO
                0372       ENDDO
da754645e6 Jean*0373 # endif /* SHORTWAVE_HEATING */
                0374 #endif /* ALLOW_ATM_TEMP */
b7bd8a1e5a Patr*0375 
14a20b48a3 Jean*0376 C     Diagnostics output
423768d890 Jean*0377       CALL EXF_DIAGNOSTICS_FILL( myTime, myIter, myThid )
b1e3781773 Patr*0378 
14a20b48a3 Jean*0379 C     Monitor output
423768d890 Jean*0380       CALL EXF_MONITOR( myTime, myIter, myThid )
d9263fe447 Jean*0381 
14a20b48a3 Jean*0382 C     Map the forcing fields onto the corresponding model fields.
423768d890 Jean*0383       CALL EXF_MAPFIELDS( myTime, myIter, myThid )
7f861c1808 Patr*0384 
423768d890 Jean*0385 #ifdef ALLOW_AUTODIFF
14a20b48a3 Jean*0386 # ifdef ALLOW_AUTODIFF_MONITOR
                0387       IF ( .NOT. useSEAICE )
7e9378bd0f Patr*0388      &     CALL EXF_ADJOINT_SNAPSHOTS( 3, myTime, myIter, myThid )
                0389 # endif
423768d890 Jean*0390 #endif /* ALLOW_AUTODIFF */
7e9378bd0f Patr*0391 
e1fb02e8f0 Jean*0392       RETURN
                0393       END