Index: CPL/oasis3/trunk/src/lib/anaisg/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/Makefile	(revision 1677)
@@ -0,0 +1,51 @@
+
+SRCS4 	= $(shell ls ../../../../src/lib/anaisg/src/*.f)
+OBJS4 	= $(patsubst ../../../../src/lib/anaisg/src/%.f, %.o, $(SRCS4))
+
+VPATH 	= ../../../../src/lib/anaisg/src:../../../../src/mod/$(COUPLE)/src
+
+LIBRARY	= ../../../lib/libanaisg.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS4)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS4)
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# ALL dependencies ...
+#
+
+mod_parameter.o: mod_kinds_oasis.o
+mod_printing.o: mod_kinds_oasis.o
+mod_unit.o: mod_kinds_oasis.o
+mod_analysis.o: mod_kinds_oasis.o
+nagset.o: mod_parameter.o mod_analysis.o mod_unit.o mod_printing.o mod_kinds_oasis.o
+nagsst.o: mod_unit.o mod_printing.o mod_kinds_oasis.o
+qcscur.o: mod_unit.o mod_kinds_oasis.o
+qgrhal.o: mod_unit.o mod_kinds_oasis.o
+qgrho.o: mod_unit.o mod_kinds_oasis.o
+qlgaus.o: mod_unit.o mod_kinds_oasis.o
+qlins.o: mod_unit.o mod_kinds_oasis.o
+qlsort.o: mod_unit.o mod_kinds_oasis.o
+qlsst.o: mod_unit.o mod_kinds_oasis.o
Index: CPL/oasis3/trunk/src/lib/anaisg/src/nagset.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/nagset.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/nagset.f	(revision 1677)
@@ -0,0 +1,482 @@
+      SUBROUTINE nagset(px1, py1, p1surf,
+     $                  kmsk1, kvmsk1, kngx1, kngy1,
+     $                  px2, py2, p2surf,
+     $                  kmsk2, kvmsk2, kngx2, kngy2,
+     $                  cdtyp,
+     $                  pr1to2, k1to2, kw1to2, psgr1, psgr2,
+     $                  psz12, krdwt, kwlun, knumber)
+C****
+C
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *nagset* - Initializations for the global anais method
+C
+C     Purpose:
+C     -------
+C     Assumes curvilinear grid when calling pcscur
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *nagset(px1, py1, p1surf, kmsk1, kvmsk1, kngx1, kngy1,
+C                       px2, py2, p2surf, kmsk2, kvmsk2, kngx2, kngy2,
+C                       pr1to2, k1to2, kw1to2, psgr1, psgr2, 
+C                       psz12, krdwt, kwlun, knumber)*
+C     Input:
+C     -----
+C                kngx1   : number of longitudes for source grid
+C                kngy1   : number of latitudes for source grid
+C                px1     : longitudes for source grid (real 2D)
+C                py1     : latitudes for source grid (real 2D)
+C                p1surf  : grid square surfaces for source grid (real 2D)
+C                kmsk1   : the mask for source grid (integer 2D)
+C                kvmsk1  : the value of the mask for source grid
+C                kngx2   : number of longitudes for target grid
+C                kngy2   : number of latitudes for target grid
+C                px2     : longitudes for target grid (real 2D)
+C                py2     : latitudes for target grid (real 2D)
+C                p2surf  : grid square surfaces for target grid (real 2D)
+C                kmsk2   : the mask of target grid (integer 2D)
+C                kvmsk2  : the value of the mask for target grid
+C                cdtyp   : type of source grid  
+C                psz12   : variance multiplicator
+C                kw1to2  : number of neighbors used for the weights
+C                krdwt   : read/write flag for the weights
+C                kwlun   : logical unit for the weights
+C                knumber : flag to identify appropriate Anaism dataset
+C
+C     Output:
+C     ------
+C                pr1to2  : weights for Anaism interpolation (real 2D)
+C                k1to2   : source grid neighbors adresses (integer 2D)
+C                psgr1   : source grid spherical surface (p1surf/Rearth**2)
+C                psgr2   : target grid spherical surface (p2surf/Rearth**2)
+C                  
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     qcscur, ssumr, grstat, qgrhal, icoor, jcoor
+C     locwrint, locwrite, locread, locrint,
+C     
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual(1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/12/01  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_analysis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px1(kngx1,kngy1), py1(kngx1,kngy1), 
+     $    psgr1(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) px2(kngx2,kngy2), py2(kngx2,kngy2), 
+     $    psgr2(kngx2,kngy2)
+      REAL (kind=ip_realwp_p) pr1to2(kw1to2,kngx2*kngy2), 
+     $    p1surf(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) p2surf(kngx2,kngy2) 
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx1,kngy1), kmsk2(kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) k1to2(kw1to2,kngx2*kngy2)
+      CHARACTER*1 cdtyp
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 cladress, clweight
+      CHARACTER*1 cltyp
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations and checkings
+C        -----------------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '           ROUTINE nagset  -  Level 3'
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    ' Set up global anais interpolation'
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Define global dimensions and other local variables
+C
+      ing1 = kngx1 * kngy1
+      ing2 = kngx2 * kngy2
+      ivmsk1 = kvmsk1
+      ivmsk2 = kvmsk2
+      iflag = 0
+C
+C* Locators
+C
+      WRITE(clweight,'(''WEIGHTS'',I1)') knumber
+      WRITE(cladress,'(''ADRESSE'',I1)') knumber
+C
+C* Printing
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulan,FMT = *) '           ANAIS output FILE '
+          WRITE (UNIT = nulan,FMT = *) '           ***** ****** **** '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) '            Routine nagset '
+          WRITE (UNIT = nulan,FMT = *) '            -------------- '
+          WRITE (UNIT = nulan,FMT = *) ' '
+      ENDIF
+C
+C*    2. Statistics of source grid
+C        -------------------------
+C
+      cltyp = cdtyp
+C* The following routines calculate some info about the grids
+C* if mesh surface information is present
+C 
+C* Calculate surface elements (curvilinear)
+C
+      itot = 0
+      DO 200 ix = 1, kngx1
+        DO 210 iy = 1, kngy1 
+          IF (p1surf(ix, iy) .eq. 0.) itot = itot + 1
+ 210    CONTINUE
+ 200  CONTINUE
+      IF (itot .eq. ing1) THEN
+         WRITE (UNIT = nulan,FMT = *) 'No statistics will be performed'
+         WRITE (UNIT = nulan,FMT = *) 'on source grid as the mesh area'
+         WRITE (UNIT = nulan,FMT = *) 'info is not present.'
+      ELSE
+          CALL qcscur (psgr1, kngx1, kngy1, p1surf)
+          zsum = ssumr (psgr1, ing1)
+C
+C* Printing on ANAIS output file
+C
+          IF (nlogprt .GE. 2) THEN
+              WRITE (UNIT = nulan,FMT = *) 
+     $            '      Some statistics about the source grid '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            '      ************************************* '
+              WRITE (UNIT = nulan,FMT = *) ' '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Sum of grid square surfaces = ', zsum
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' It must be equal to 4 x PI  = ', 16. * atan(1.)
+              WRITE (UNIT = nulan,FMT = *) ' '
+          ENDIF
+      ENDIF
+C
+C* Calculate for ocean points (unmasked points) the following data :
+C                ************
+C           - total surface
+C           - average inter-point distance
+C           - inverse of the sum of surface elements squared
+C* Note: The surface and the sum of surface elements squared will not 
+C  be significant IF no information on grid mesh is present but the 
+C  average inter-point distance will be significant and used after.
+C
+      CALL grstat (px1, py1, psgr1, kmsk1, kngx1, kngy1, cltyp,
+     $    zamsh1, zstot1, zhhi1, ivmsk1) 
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $        ' Ocean average mesh distance = ', sqrt(zamsh1) 
+      ENDIF
+      IF (itot .ne. ing1) then
+C* Printing
+C
+          IF (nlogprt .GE. 2) THEN  
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' ******************************* '
+              WRITE (UNIT = nulan,FMT = *) 'Ocean total surface = ', 
+     $            zstot1
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Ocean inverse of sum surf. elts. squared = ', zhhi1
+          ENDIF
+      ENDIF
+C
+C
+C*    3. Statistics of target grid
+C        -------------------------
+C
+      itot = 0
+      DO 300 ix = 1, kngx2
+        DO 310 iy = 1, kngy2 
+          IF (p2surf(ix, iy) .eq. 0.) itot = itot + 1
+ 310    CONTINUE
+ 300  CONTINUE
+      IF (itot .eq. ing2) THEN
+         WRITE (UNIT = nulan,FMT = *) 'No statistics will be performed'
+         WRITE (UNIT = nulan,FMT = *) 'on target grid as the mesh area'
+         WRITE (UNIT = nulan,FMT = *) 'info is not present.'
+      ELSE
+C*       The following routines calculate some interesting info 
+C*       about the target grid
+C
+C*       Calculate surface elements (curvilinear)
+C
+          CALL qcscur (psgr2, kngx2, kngy2, p2surf)
+          zsum = ssumr (psgr2, ing2)
+          IF (nlogprt .GE. 2) THEN  
+              WRITE (UNIT = nulan,FMT = *) ' '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            '      Some statistics about the target grid '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            '      ************************************* '
+              WRITE (UNIT = nulan,FMT = *) ' '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Sum of grid square surfaces = ', zsum
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' It must be equal to 4 x PI  = ', 
+     $            16. * atan(1.) 
+              WRITE (UNIT = nulan,FMT = *) ' '
+          ENDIF
+C
+C* Calculate for ocean points (unmasked points) the following data :
+C                ************
+C           - total surface
+C           - average inter-point distance
+C           - inverse of the sum of surface elements squared
+C
+          CALL grstat (px2, py2, psgr2, kmsk2, kngx2, kngy2, cltyp,
+     $        zamsh2, zstot2, zhhi2, ivmsk2)
+C
+C* Printing
+C
+          IF (nlogprt .GE. 2) THEN  
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Some info for ocean points only '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' ******************************* '
+              WRITE (UNIT = nulan,FMT = *) ' '
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Average mesh distance = ', sqrt(zamsh2)
+              WRITE (UNIT = nulan,FMT = *) ' Total surface = ', zstot2
+              WRITE (UNIT = nulan,FMT = *) 
+     $            ' Inverse of sum surf. elts. squared = ', zhhi2
+          ENDIF
+      ENDIF
+C
+C
+C*    4. Preparation of the neighbour search
+C        -----------------------------------
+C
+C* Consistency checking
+C
+      IF (kw1to2 .GT. ing2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' WARNING: kw1to2 .gt. ing2 '
+          WRITE (UNIT = nulou,FMT = *) ' *******  ------      ---- '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' kw1to2 = ',kw1to2,' ing2 = ',ing2
+      ENDIF
+C
+C* Variance for gaussian weight function
+C
+      zs1to2 = zamsh1 * psz12
+C
+C* Printing
+C
+      IF (nlogprt .GE. 2) THEN    
+          WRITE(UNIT = nulan,FMT = *) ' '
+          WRITE(UNIT = nulan,FMT = *) 
+     $    ' Gaussian variance is zs1to2 = ', zs1to2
+          WRITE(UNIT = nulan,FMT = *) ' '
+      ENDIF
+C
+C
+C*    5. Weights determination
+C        ---------------------
+C
+C* Initialization for read write options
+C 
+      IF (krdwt .EQ. 1) THEN
+C
+C* Writing
+C  -------
+C
+C* Calculates and write weights after checking numbers 
+C
+C* Calculates weights 
+C
+          CALL qgrhal (pr1to2, k1to2, kw1to2,
+     $                 px2, py2, kmsk2, kngx2, kngy2,
+     $                 px1, py1, kmsk1, kngx1, kngy1, 
+     $                 zs1to2, ivmsk1, ivmsk2)
+C
+C* Write  weights + other useful stuff
+C
+C* - write main locator string + weights
+C
+          CALL locwrite (clweight, pr1to2, kw1to2*kngx2*kngy2, 
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+              CALL HALTE ('Stop in nagset')
+          ENDIF
+C
+C* - write nearest neighbors adresses
+C
+          CALL locwrint (cladress, k1to2, kw1to2*kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+              CALL HALTE ('Stop in nagset')
+          ENDIF
+C
+C* - write  checkings numbers (grid parameters)
+C
+          write(kwlun) kngx1, kngy1, kngx2, kngy2
+C
+C* Job is done
+C
+          IF (nlogprt .GE. 2) THEN  
+              CALL prtout('Wrote weights on unit = ', kwlun, 1) 
+          ENDIF
+C
+C* Reading
+C  -------
+C
+        ELSE
+C
+C* Reads weights and checks  
+C
+C* - Read weight locator string + weights
+C
+          CALL locread (clweight, pr1to2, kw1to2*kngx2*kngy2, 
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+              CALL HALTE ('Stop in nagset')
+          ENDIF
+C
+C* - Read nearest neighbors adresses
+C
+          CALL locrint (cladress, k1to2, kw1to2*kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+              CALL HALTE ('Stop in nagset')
+          ENDIF
+C
+C* - Read  checkings numbers (grid parameters)
+C
+          READ(kwlun) ingx1, ingy1, ingx2, ingy2
+C
+C* Checks
+C
+          IF (ingx1 .NE. kngx1 .OR. ingy1 .NE. kngy1 .OR. 
+     $        ingx2 .NE. kngx2 .OR. ingy2 .NE. kngy2) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' Inconsistency in gweights file'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingx1 = ',ingx1,'kngx1 = ',kngx1
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingy1 = ',ingy1,'kngy1 = ',kngy1
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingx2 = ',ingx2,'kngx2 = ',kngx2
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingy2 = ',ingy2,'kngy2 = ',kngy2
+              CALL HALTE ('Stop in nagset')
+          ENDIF
+C
+C* Reading of weights done
+C
+          IF (nlogprt .GE. 2) THEN 
+              CALL prtout
+     $        ('Reading of weights done on unit = ', kwlun, 1)
+          ENDIF
+      ENDIF
+C
+C
+C*    6. Printing weights and adresses on ANAIS output file
+C        --------------------------------------------------
+C
+      IF (nlogprt .GE. 2) THEN  
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Print weights and adresses of nearest neighbors '
+          WRITE (UNIT = nulan,FMT = *)
+     $    ' *********************************************** '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = 6030) kw1to2
+          DO 610 jj = 1, kngy2 
+            DO 620 ji = 1, kngx2
+              WRITE (UNIT = nulan,FMT = 6010) ji, jj
+              WRITE (UNIT = nulan,FMT = 6020) px2(ji,jj), py2(ji,jj)
+              IF (kmsk2(ji,jj) .EQ. 0) THEN 
+                  DO 630 jn = 1, kw1to2
+                    iind = ji + kngx2 * (jj-1)
+                    iadr = k1to2(jn,iind)
+                    ix = icoor(iadr,kngx1)
+                    iy = jcoor(iadr,kngx1)
+                    WRITE(UNIT = nulan,FMT = 6040) jn, pr1to2(jn,iind)
+                    WRITE(UNIT = nulan,FMT = 6050) 
+     $              ix, iy, px1(ix,iy), py1(ix,iy)
+ 630              CONTINUE 
+              ELSE
+                  WRITE(UNIT = nulan,FMT = 6060)
+              ENDIF 
+ 620        CONTINUE
+ 610      CONTINUE
+          CALL FLUSH(nulan)
+      ENDIF
+C
+C* Formats
+C
+ 6010 FORMAT(/,' Target grid point --  i = ',I3,' j = ',I3)
+ 6020 FORMAT(' Point coordinates -- long = ',F9.4,' lat = ',F9.4)
+ 6030 FORMAT(3X,'Number of nearest source grid neighbors = ',I3)
+ 6040 FORMAT(5X,' neighbor number = ',I3,' weight is = ',F6.4)
+ 6050 FORMAT(5X,' i = ',I3,' j = ',I3,' lon = ',F9.4,' lat = ',F9.4)
+ 6060 FORMAT(5X,' This is a continental point on the target grid ')
+C
+C
+C*    7. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN  
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine nagset ---------'
+          CALL FLUSH(nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/nagsst.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/nagsst.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/nagsst.f	(revision 1677)
@@ -0,0 +1,121 @@
+      SUBROUTINE nagsst (pflda, kmska, kvmska, kngxa, kngya,
+     $                   prbtoa, kbtoa, kwbtoa,
+     $                   pfldb, kngxb, kngyb)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *nagsst* -  Interpolation  Anais-global  without constraints 
+C
+C     Purpose:
+C     -------
+C     Interpolate with a nearest neighbor method
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *nagsst(pflda, kmska, kvmska, kngxa, kngya,
+C                       prbtoa, kbtoa, kwbtoa,
+C                       pfldb, kngxb, kngyb)*
+C
+C     Input:
+C     -----
+C                kmska  : mask for target grid (integer 2D)
+C                kvmska : the value of the mask for target grid
+C                kngxa  : number of longitudes for target grid
+C                kngya  : number of latitudes for target grid
+C                prbtoa : weights for Anaisg interpolation (real 2D)
+C                kbtoa  : source grid neighbors adresses (integer 2D)
+C                kwbtoa : maximum number of nearest neighbors
+C                pfldb  : field on source grid (real 2D)
+C                kngxb  : number of longitudes for source grid
+C                kngyb  : number of latitudes for source grid
+C
+C     Output:
+C     ------
+C                pflda: field on target grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     qlsst
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C     
+      REAL (kind=ip_realwp_p) pflda(kngxa,kngya), pfldb(kngxb,kngyb)
+      REAL (kind=ip_realwp_p) prbtoa(kwbtoa,kngxb*kngyb)
+      INTEGER (kind=ip_intwp_p) kmska(kngxa,kngya), 
+     $    kbtoa(kwbtoa,kngxb*kngyb)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations and checkings
+C        -----------------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE nagsst  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Does Anais-global interpolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Define global dimensions
+C
+      inga = kngxa * kngya
+      ingb = kngxb * kngyb
+C
+C
+C*    2. Interpolation
+C        -------------
+C
+      CALL qlsst (pflda, prbtoa, kbtoa, kwbtoa, inga, pfldb,
+     $            ingb, kmska, kvmska)
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine nagsst ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qcscur.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qcscur.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qcscur.f	(revision 1677)
@@ -0,0 +1,97 @@
+      SUBROUTINE qcscur (psgr, kngx, kngy, psurf)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL T *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qcscur* - Arithmetic routine
+C                
+C
+C     Purpose:
+C     -------
+C     Calculate surface element for orth.& curvil. grid.
+C     The input surface contains the Rearth**2 factor.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *qcscur(psgr, kngx, kngy, psurf)*
+C
+C     Input:
+C     -----
+C                psurf : grid square surface elements (real 2D)
+C                kngx  : number of longitudes
+C                kngy  : number of latitudes
+C
+C     Output:
+C     ------
+C                psgr  : spheric grid square surface elements (real 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.0       O. Thual       93/04/15  created 
+C       1.1       E. Guilyardi   93/11/04  modified
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C     
+      REAL (kind=ip_realwp_p) psurf(kngx,kngy)
+      REAL (kind=ip_realwp_p) psgr(kngx,kngy)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations
+C        ---------------
+C
+      zradi = 6371229.
+      zradi2 = zradi**2
+      zradinv = 1. / zradi2
+C
+C
+C*    2. Surfaces 
+C        --------
+C* Surface calculation
+C
+      DO 210 j2 = 1, kngy
+        DO 220 j1 = 1, kngx
+          psgr(j1,j2) = psurf(j1,j2) * zradinv
+ 220    CONTINUE
+ 210  CONTINUE
+C
+C* End of routine
+C
+      RETURN 
+      END
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qgrhal.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qgrhal.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qgrhal.f	(revision 1677)
@@ -0,0 +1,119 @@
+      SUBROUTINE qgrhal (prho2, k1to2, kwg2,
+     $                   px2, py2, kmsk2, kngx2, kngy2,
+     $                   px1, py1, kmsk1, kngx1, kngy1,
+     $                   ps12, kvma1, kvma2)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qgrhal* - Calculate weights and adresses for all the target grid
+C
+C     Purpose:
+C     -------
+C     For each point of a target grid 2 give the lpwg2 nearest neighbours 
+C     adresses k1to2 in source grid 1 and their weight which is function of
+C     the distance and maybe other grid dependant considerations. 
+C 
+C     N.B : the calculation is done only over unmasked points
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *qgrhal (prho2, k1to2, kwg2,
+C                        px2, py2, kmsk2, kngx2, kngy2,
+C                        px1, py1, kmsk1, kngx1, kngy1,
+C                        ps12, kvma1, kvma2)*    
+C
+C     Input:
+C     -----
+C                kwg2    : maximum number of nearest neighbors
+C                px1     : longitudes for source grid (real 2D)
+C                py1     : latitudes for source grid (real 2D)
+C                kmsk1   : the mask for source grid (integer 2D)
+C                kngx1   : number of longitudes for source grid
+C                kngy1   : number of latitudes for source grid
+C                px2     : longitudes for target grid (real 2D)
+C                py2     : latitudes for target grid (real 2D)
+C                kmsk2   : the mask of target grid (integer 2D)
+C                kngx2   : number of longitudes for target grid
+C                kngy2   : number of latitudes for target grid
+C                ps12    : gaussian variance
+C                kvma1   : the value of the mask for source grid
+C                kvma2   : the value of the mask for target grid 
+C
+C     Output:
+C     ------
+C                prho2   : weights for Anaism interpolation (real 3D)
+C                k1to2   : source grid neighbors adresses (integer 3D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     qgrho: to calculate the weights and adresses at one point
+C 
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, Epicoa 0629 (1992)
+C               Part B: Software implementation, Epicoa 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.0       O. Thual       93/04/15  created 
+C       1.1       E. Guilyardi   93/11/23  modified
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) prho2(kwg2,kngx2,kngy2)
+      REAL (kind=ip_realwp_p) px1(kngx1,kngy1), py1(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) px2(kngx2,kngy2), py2(kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx1,kngy1), kmsk2(kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) k1to2(kwg2,kngx2,kngy2)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Neighbours determination
+C        ------------------------
+C
+      DO 110 j2 = 1, kngy2
+        DO 120 j1 = 1, kngx2
+C
+C* For all target grid points:  zero all weights and set adresses to one
+C 
+          DO 130 jwg = 1, kwg2
+            prho2(jwg,j1,j2) = 0.
+            k1to2(jwg,j1,j2) = 1 
+ 130      CONTINUE
+C
+C* Calculate weights for unmasked points
+C
+          IF (kmsk2(j1,j2) .NE. kvma2) THEN 
+              CALL qgrho (prho2(1,j1,j2), k1to2(1,j1,j2), kwg2,
+     $                    px2(j1,j2), py2(j1,j2),
+     $                    px1, py1, kmsk1, kngx1, kngy1,
+     $                    ps12, kvma1)
+          ENDIF 
+ 120    CONTINUE
+ 110  CONTINUE 
+C
+C* End of routine
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qgrho.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qgrho.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qgrho.f	(revision 1677)
@@ -0,0 +1,224 @@
+      SUBROUTINE qgrho (prho, kto, kwg,
+     $                  px, py,
+     $                  px1, py1, kmsk1, kngx1, kngy1,
+     $                  psig, kvma1)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qgrho* - Calculate weights and adresses at one location 
+C
+C     Purpose:
+C     -------
+C     At one location xgr gives the kwg closest neighbours 
+C     adresses kto in grid 1 and their weight, which is function of
+C     the distance and may be other grid dependant considerations. 
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *qgrho(prho, kto, kwg,
+C                      px, py,
+C                      px1, py1, kmsk1, kngx1, kngy1,
+C                      psig, kvma1)* 
+C
+C     Input:
+C     -----
+C                kwg   : maximum number of overlapped neighbors
+C                px    : longitude of the current point on target grid
+C                py    : latitude of the current point on source grid
+C                px1   : longitudes for source grid (real 2D)
+C                py1   : latitudes for source grid (real 2D)
+C                kmsk1 : the mask for source grid (integer 2D)
+C                kngx1 : number of longitudes for source grid
+C                kngy1 : number of latitudes for source grid
+C                kvma1 : the value of the mask for source grid
+C                psig  : variance of the gaussian
+C     Output:
+C     ------
+C                prho  : the neighbors weights 
+C                kto   : the neighbors adresses in the source grid 
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     qlsort, sqdis, qlins, qlgaus
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px1(kngx1,kngy1), py1(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) prho(kwg)
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx1,kngy1)
+      INTEGER (kind=ip_intwp_p) kto(kwg)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C     
+C*    1. Various initializations
+C        -----------------------
+C
+C* Value of the mask
+C
+      ivma = kvma1
+      ing = kngx1 * kngy1
+C
+C
+C*    2. Nearest neighbors search
+C        ------------------------
+C
+C* Checks
+C     
+      IF (kwg .GT. ing) THEN
+          WRITE (UNIT = nulou,FMT = *) 'WARNING kwg = ',kwg,
+     $                  '.GT. kngx1*kngy1 = ',ing
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Number of searched neighbors greater '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' than number of grid points '
+          iwg = ing
+          WRITE (UNIT = nulou,FMT = *)  'We set  iwg = ing = ',iwg
+        ELSE
+         iwg = kwg
+      ENDIF
+C
+C
+C* Put first iwg unmasked points of source grid in kto and prho
+C
+      iind = 0
+      DO 210 j2 = 1, kngy1
+        DO 220 j1 = 1, kngx1
+          IF (kmsk1(j1,j2) .NE. ivma) THEN
+              iind = iind + 1
+              icum = (j2-1) * kngx1 + j1
+              prho(iind) = sqdis (px, py, px1(j1,j2), py1(j1,j2))
+              kto(iind) = icum
+              i1t = j1
+              i2t = j2
+              IF (iind .EQ. iwg) GO TO 225
+          ENDIF
+ 220    CONTINUE 
+ 210  CONTINUE
+ 225  CONTINUE
+C
+C* Check
+C
+      IF (iind .NE. iwg) THEN
+          WRITE(UNIT = nulou,FMT = *) 
+     $        ' WARNING: iind.ne.iwg ===> ',iind, iwg
+          WRITE(UNIT = nulou,FMT = *) 
+     $        ' *******  ===> Program must stop '
+          CALL HALTE ('STOP in qgrho')
+      ENDIF
+C
+C* Sorting of these first iwg points
+C
+      CALL qlsort (prho, kto, iwg)
+C
+C* Loop on the remaining points of source grid
+C
+      IF (iwg .NE. ing) THEN    
+C
+C* Loop over the remaining longitudes for latitude i2t on source grid 
+C  if necessary
+C
+          IF (i1t .LT. kngx1) THEN	
+              DO 230 j1 = i1t+1, kngx1
+                IF (kmsk1(j1,i2t) .NE. ivma) THEN
+                    icum = (i2t-1) * kngx1 + j1
+C
+C* Calculate distance between the current source grid point and
+C  the given target grid point
+C
+                    zrnew = sqdis (px, py, px1(j1,i2t), py1(j1,i2t))
+C
+C* Insert in list at the correct rank
+C
+                    CALL qlins (prho, kto, iwg, zrnew, icum)
+                ENDIF
+ 230          CONTINUE 
+          ENDIF
+C
+C* Loop over the remaining source grid points
+C
+          DO 240 j2 = i2t+1, kngy1
+            DO 250 j1 = 1, kngx1
+              IF (kmsk1(j1,j2) .NE. ivma) THEN
+                  icum = (j2-1) * kngx1 + j1
+C
+C* Calculate distance between the current source grid point and
+C  the given target grid point
+C
+                  zrnew = sqdis (px, py, px1(j1,j2), py1(j1,j2))
+C
+C* Insert in list at the correct rank
+C
+                  CALL qlins (prho, kto, iwg, zrnew, icum)
+              ENDIF
+ 250        CONTINUE 
+ 240      CONTINUE
+      ENDIF
+C 
+C
+C*    3. Weight function
+C        ---------------
+C
+C* Gaussian value for the weight function
+C
+      zsum = 0.
+      DO 310 jwg = 1, iwg
+          zr = qlgaus (prho(jwg), psig)
+          zsum = zsum + zr
+          prho(jwg) = zr
+ 310  CONTINUE
+C
+C* Normalization
+C
+      zthres = 1.e-6
+C
+C* If under threshold
+C
+      IF (zsum .LT. zthres) THEN
+          WRITE(UNIT=nulou,FMT=*) 'Gaussian sum under threshold value'
+          DO 320 jwg = 1, iwg
+            prho(jwg) = 1. / float(iwg)
+ 320      CONTINUE
+C
+        ELSE
+C
+C* If above threshold
+C
+          DO 330 jwg = 1, iwg
+            prho(jwg) = prho(jwg) / zsum
+ 330      CONTINUE
+      ENDIF
+C
+C* End of routine
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qlgaus.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qlgaus.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qlgaus.f	(revision 1677)
@@ -0,0 +1,72 @@
+      FUNCTION qlgaus (pu, pvar)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL 3 *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *qlgaus* - Gaussian weight function
+C
+C
+C     Purpose: 
+C     -------
+C     To calculate exp [-.5 * u / pvar]
+C
+C
+C**   Interface:
+C     ---------
+C       *zz=*   *qlgaus(pu, pvar)*
+C
+C     Input:
+C     -----   
+C                pu   : the distance squared
+C                pvar :  the gaussian variance
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+      REAL (kind=ip_realwp_p) :: qlgaus
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Calculation
+C        -----------
+C
+      qlgaus = exp(-.5*pu/pvar)
+C
+C* End of FUNCTION
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qlins.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qlins.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qlins.f	(revision 1677)
@@ -0,0 +1,113 @@
+      SUBROUTINE qlins (prho, kto, kwg, prnew, kjwg)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qlins* - Insert a new element in a sorted list
+C
+C     Purpose:
+C     -------
+C     Given a sorted array prho and associated array kto of indices
+C     of length klwg, insert a new element prnew in prho, if needed,
+C     and  kjwg in kto accordingly, and trash the lowest element.
+C
+C     N.B: The method is a trivial one. The first element is assumed 
+C     to be the smallest and then tested against the following 
+C     one. If an element is smallest a permutation is made, 
+C     and the testing goes on with the next elements. There
+C     is no need to test again the  elements previously tested
+C     as they are known to be greater. At the end of the loop
+C     the smallest is in first position, and we repeat the 
+C     the procedure with the array starting in position two
+C     and so on.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *qlins (prho, kto, kwg, prnew, kjwg)*
+C
+C     Input:
+C     -----
+C                prho  : array to be sorted
+C                kto   : array to be re-arranged as prho
+C                kwg   : size of prho and kto
+C                prnew : the new vallue to insert in prho, if needed
+C                kjwg  : to be inserted in kto accordingly
+C 
+C     Output:
+C     ------
+C                prho  : the sorted array
+C                kto   : the re-arranged array
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) prho(kwg)
+      INTEGER (kind=ip_intwp_p) kto(kwg)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C 
+C*    1. Insertion
+C        ---------
+C     
+C* If kwg is equal to one: nothing special 
+C
+C* Loop on all the positions
+C
+      DO 110 jwg = 1, kwg
+        zsmal = prho(jwg)
+C          
+C* Testing if insertion is needed 
+C
+        IF (zsmal .GT. prnew) THEN
+C             
+C* Shift to insert new value excepted the last element
+C
+            IF (jwg .NE. kwg) THEN
+                ijwgp = jwg + 1
+                DO 120 ji = kwg, ijwgp, -1
+                  prho(ji) = prho(ji-1)
+                  kto(ji) = kto(ji-1)
+ 120            CONTINUE
+            ENDIF
+            prho(jwg) = prnew
+            kto(jwg) = kjwg
+            RETURN
+        ENDIF
+ 110  CONTINUE
+C
+C* End of routine
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qlsort.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qlsort.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qlsort.f	(revision 1677)
@@ -0,0 +1,118 @@
+      SUBROUTINE qlsort (prho, kto, kwg)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qlsort* - Sort kwg numbers with adresses
+C
+C     Purpose:
+C     -------
+C     Given kwg real in prho, this routine sort them and
+C     rearrange the array kto in the same way.
+C
+C     N.B: The method is a trivial one. the first element is assumed 
+C     to be the smallest and then tested against the following 
+C     one. If an element is smallest a permutation is made, 
+C     and the testing goes on with the next elements. There
+C     is no need to test again the  elements previously tested
+C     as they are known to be greater. At the end of the loop
+C     the smallest is in first position, and we repeat the 
+C     the procedure with the array starting in position two
+C     and so on.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *qlsort (prho, kto, kwg)*
+C
+C     Input:
+C     -----
+C                prho  : array to be sorted
+C                kto   : array to be re-arranged as prho
+C                kwg   : size of prho and kto
+C
+C     Output:
+C     ------
+C                prho  : the sorted array
+C                kto   : the re-arranged array 
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) prho(kwg)
+      INTEGER (kind=ip_intwp_p) kto(kwg)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C   
+C*    1. Sorting algorithm
+C        -----------------
+C     
+C* If kwg is equal to one no sorting is needed
+C
+      IF (kwg .EQ. 1) RETURN
+C
+C* Loop on all the positions
+C
+      ikwgm = kwg - 1
+      DO 110 jwg = 1, ikwgm
+        ijwgp = jwg + 1
+C
+C* Loop on the element following the position
+C
+        DO 120 jnext = ijwgp, kwg 
+          zsmal = prho(jwg)
+          zbig = prho(jnext)
+C
+C* Testing the smallness assumption
+C
+          IF (zsmal .GT. zbig) THEN
+C
+C* Permutation of prho
+C 
+              prho(jnext) = zsmal
+              prho(jwg) = zbig
+C
+C* Permutation of kto
+C
+              ikbig = kto(jnext)
+              kto(jnext) = kto(jwg)
+              kto(jwg) = ikbig
+          ENDIF
+ 120    CONTINUE
+ 110  CONTINUE
+C
+C* End of routine
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/anaisg/src/qlsst.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaisg/src/qlsst.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaisg/src/qlsst.f	(revision 1677)
@@ -0,0 +1,96 @@
+       SUBROUTINE qlsst (pqta, prho, kto, kwg, knga, pqtb,
+     $                   kngb, kmska, kvma)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *qlsst* - Interpolate a field with a ponderation technique
+C
+C     Purpose:
+C     -------
+C     Given the weights prho and indices kto of field pqtb on a source grid,
+C     performs a ponderation to generate pqta on target grid.
+C 
+C     N.B: Nothing is done for the masked points 
+C     
+C**   Interface:
+C     ---------
+C       *CALL* *qlsst*(pqta, prho, kto, kwg, knga, pqtb, kngb,
+C                      kmska, pmask, kvma)*
+C
+C     Input:
+C     -----
+C               prho: array, the weights
+C               kto: array, the indices in source grid
+C               kwg: the number of neighbors
+C               knga: the target grid size
+C               pqtb: array, the field on source grid
+C               kngb: the source grid size
+C               kmska: mask of the target grid
+C               kvma:  value of the mask on target grid
+C
+C     Output:
+C     ------
+C               pqta: array, the field to calculate
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.0       O. Thual       93/04/15  created 
+C       1.1       E. Guilyardi   93/11/23  modified
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pqtb(kngb), pqta(knga), prho(kwg,knga)
+      INTEGER (kind=ip_intwp_p) kmska(knga), kto(kwg,knga)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C 
+C*    1. Ponderation
+C        -----------
+C
+      DO 110 j1 = 1, knga
+C
+C* Nothing happens if it is a continental point
+C
+        IF (kmska(j1) .NE. kvma) THEN
+            zsum = 0.
+            DO 120 j2 = 1, kwg
+              zsum = zsum + prho(j2,j1) * pqtb(kto(j2,j1))
+ 120        CONTINUE
+            pqta(j1) = zsum
+        ENDIF
+ 110  CONTINUE
+C
+C* End of routine
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaism/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/Makefile	(revision 1677)
@@ -0,0 +1,49 @@
+
+SRCS4 =  $(shell ls ../../../../src/lib/anaism/src/*.f)
+OBJS4 =  $(patsubst ../../../../src/lib/anaism/src/%.f, %.o, $(SRCS4))
+
+VPATH =	../../../../src/lib/anaism/src:../../../../src/mod/$(COUPLE)/src
+
+LIBRARY	= ../../../lib/libanaism.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS4)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS4)
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# ALL dependencies ...
+#
+
+mod_parameter.o: mod_kinds_oasis.o
+mod_printing.o: mod_kinds_oasis.o
+mod_unit.o: mod_kinds_oasis.o
+namset.o: mod_unit.o mod_printing.o mod_kinds_oasis.o
+pcssph.o: mod_unit.o mod_kinds_oasis.o
+plsst.o: mod_unit.o mod_kinds_oasis.o
+pmesh.o: mod_unit.o mod_kinds_oasis.o
+pminm.o: mod_unit.o mod_kinds_oasis.o
+pmrhal.o: mod_unit.o mod_kinds_oasis.o
+pmrho.o: mod_unit.o mod_kinds_oasis.o
+
Index: CPL/oasis3/trunk/src/lib/anaism/src/namset.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/namset.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/namset.f	(revision 1677)
@@ -0,0 +1,471 @@
+      SUBROUTINE namset (px1, py1, kmsk1, kvmsk1, kngx1, kngy1, 
+     $                   cdper1, kper1,
+     $                   px2, py2, kmsk2, kvmsk2, kngx2, kngy2, 
+     $                   cdper2, kper2,
+     $                   cdtyp,
+     $                   pr1to2, k1to2, kw1to2, psgr1, psgr2,
+     $                   krdwt, kwlun, kvmsz2,
+     $                   kmskz2, knumber)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *namset* - Initializations for the mesh naive method
+C
+C     Purpose:
+C     -------
+C     Read or calculate the interpolation weights used in Anaism
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *namset(px1, py1, kmsk1, kvmsk1, kngx1, kngy1, cdper1, kper1,
+C                       px2, py2, kmsk2, kvmsk2, kngx2, kngy2, cdper2, kper2,
+C                       pr1to2, k1to2, kw1to2, psgr1, psgr2,
+C                       krdwt, kwlun, kvmsz2,
+C                       kmskz2, knumber)*
+C     Input:
+C     -----
+C                kngx1   : number of longitudes for source grid
+C                kngy1   : number of latitudes for source grid
+C                px1     : longitudes for source grid (real 2D)
+C                py1     : latitudes for source grid (real 2D)
+C                kmsk1   : the mask for source grid (integer 2D)
+C                kvmsk1  : the value of the mask for source grid
+C                cdper1  : source grid periodicity
+C                kper1   : number of overlapped points for source grid 
+C                kngx2   : number of longitudes for target grid
+C                kngy2   : number of latitudes for target grid
+C                px2     : longitudes for target grid (real 2D)
+C                py2     : latitudes for target grid (real 2D)
+C                kmsk2   : the mask of target grid (integer 2D)
+C                kvmsk2  : the value of the mask for target grid 
+C                cdper2  : target grid periodicity
+C                kper2   : number of overlapped points for target grid
+C                cdtyp   : type of source grid 
+C                kw1to2  : maximum number of overlapped neighbors
+C                krdwt   : read/write flag for the weights
+C                kwlun   : logical unit for the weights
+C                kvmsz2  : mask value for array kmskz2
+C                knumber : flag to identify appropriate Anaism dataset
+C
+C     Output:
+C     ------
+C                pr1to2  : weights for Anaism interpolation (real 2D)
+C                k1to2   : source grid neighbors adresses (integer 2D)
+C                kmskz2  : number of source grid neighbors (integer 2D)
+C                psgr1   : source grid square surfaces (real 2D)
+C                psgr2   : target grid square surfaces (real 2D)
+C                  
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     pcssph, ssumr, grstat, pmrhal, locwrint, locwrite, locread, locrint,
+C     icoor, jcoor
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px1(kngx1,kngy1), py1(kngx1,kngy1), 
+     $    psgr1(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) px2(kngx2,kngy2), py2(kngx2,kngy2), 
+     $    psgr2(kngx2,kngy2)
+      REAL (kind=ip_realwp_p) pr1to2(kw1to2,kngx2*kngy2)
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx1,kngy1), kmsk2(kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) k1to2(kw1to2,kngx2*kngy2), 
+     $    kmskz2(kngx2,kngy2)
+      CHARACTER*8 cdper1, cdper2
+      CHARACTER*1 cdtyp
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 cladress, clweight, cloverlp
+      CHARACTER*1 cltyp
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations
+C        ---------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           Routine namset  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Set up ANAIS-MESH interpolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Define global dimensions + other local variables
+C
+      ing1 = kngx1 * kngy1
+      ing2 = kngx2 * kngy2
+      ivmsk1 = kvmsk1
+      ivmsk2 = kvmsk2
+      iflag = 0
+C
+C* Define character strings to locate needed data
+C
+      WRITE(clweight,'(''WEIGHTS'',I1)') knumber
+      WRITE(cladress,'(''ADRESSE'',I1)') knumber
+      WRITE(cloverlp,'(''OVERLAP'',I1)') knumber
+C
+C
+C*    2. Statistics of source grid
+C        -------------------------
+C
+      cltyp = cdtyp
+C* The following routines calculate some interesting info about the grids
+C
+C* Calculate surface elements (assume spherical and periodic grid)
+C
+      CALL pcssph (px1, py1, psgr1, kngx1, kngy1)
+      zsum = ssumr (psgr1, ing1)
+C
+C* Printing on ANAIS output file
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulan,FMT = *) '           ANAIS output FILE '
+          WRITE (UNIT = nulan,FMT = *) '           ***** ****** **** '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) '            Routine namset '
+          WRITE (UNIT = nulan,FMT = *) '            -------------- '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    '      Some statistics about the source grid '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    '      ************************************* '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Sum of grid square surfaces = ', zsum
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' It must be equal to 4 x PI  = ', 16. * atan(1.) 
+          WRITE (UNIT = nulan,FMT = *) ' '
+      ENDIF
+C
+C* Calculate for ocean points (unmasked points) the following data :
+C                ************
+C           - total surface
+C           - average inter-point distance
+C           - inverse of the sum of surface elements squared
+C
+      CALL grstat (px1, py1, psgr1, kmsk1, kngx1, kngy1, cltyp,
+     $             zamsh1, zstot1, zhhi1, ivmsk1) 
+C  
+C* Printing
+C 
+      IF (nlogprt .GE. 2) THEN 
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Some info for ocean points only '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' ******************************* '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Average mesh distance = ', sqrt(zamsh1)
+          WRITE (UNIT = nulan,FMT = *) ' Total surface = ', zstot1
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Inverse of sum surf. elts. squared = ', zhhi1
+      ENDIF
+C
+C
+C*    3. Statistics of target grid
+C        -------------------------
+C
+C* The following routines calculate some interesting info about the grids
+C
+C* Calculate surface elements (assume spherical and periodic grid)
+C
+      CALL pcssph (px2, py2, psgr2, kngx2, kngy2)
+      zsum = ssumr (psgr2, ing2)
+C
+C* Printing
+C
+      IF (nlogprt .GE. 2) THEN  
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    '      Some statistics about the target grid '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    '      ************************************* '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Sum of grid square surfaces = ', zsum
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' It must be equal to 4 x PI  = ', 
+     $                        16. * atan(1.) 
+          WRITE (UNIT = nulan,FMT = *) ' '
+      ENDIF
+C
+C* Calculate for ocean points (unmasked points) the following data :
+C                ************
+C           - total surface
+C           - average inter-point distance
+C           - inverse of the sum of surface elements squared
+C
+      CALL grstat (px2, py2, psgr2, kmsk2, kngx2, kngy2, cltyp,
+     $             zamsh2, zstot2, zhhi2, ivmsk2) 
+C  
+C* Printing
+C
+      IF (nlogprt .GE. 2) THEN   
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Some info for ocean points only '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' ******************************* '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Average mesh distance = ', sqrt(zamsh2)
+          WRITE (UNIT = nulan,FMT = *) ' Total surface = ', zstot2
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Inverse of sum surf. elts. squared = ', zhhi2
+      ENDIF
+C 
+C
+C*    4. Preparation of the neighbors search
+C        -----------------------------------
+C
+C* Consistency checking
+C
+      IF (kw1to2 .GT. ing2) THEN 
+          WRITE (UNIT = nulou,FMT = *) ' WARNING: kw1to2 .gt. ing2 '
+          WRITE (UNIT = nulou,FMT = *) ' *******  ------      ---- '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' kw1to2 = ',kw1to2,' ing2 = ',ing2
+      ENDIF 
+C
+C
+C*    5. Weights determination
+C        ---------------------
+C
+C* Initialization for read write options
+C 
+      IF (krdwt .EQ. 1) THEN
+C
+C* Writing
+C  -------
+C
+C* Calculate and write weights after checking numbers 
+C 
+C* Calculates weights 
+C
+          CALL pmrhal (pr1to2, k1to2, kw1to2,
+     $                 px1, py1, kmsk1, kngx1, kngy1, cdper1, kper1,
+     $                 px2, py2, kmsk2, kngx2, kngy2, cdper2, kper2,
+     $                 ivmsk1, ivmsk2, kmskz2, kvmsz2)
+C
+C* Write  weights + other useful stuff
+C
+C* - Write main locator string + weights
+C
+          CALL locwrite (clweight, pr1to2, kw1to2*kngx2*kngy2, 
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C 
+C* - Write overlapped neighbors adresses
+C
+          CALL locwrint (cladress, k1to2, kw1to2*kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C
+C* - Write overlapped neighbors numbers
+C
+          CALL locwrint (cloverlp, kmskz2, kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cloverlp
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C
+C* - Write  checkings numbers (grid parameters)
+C
+          WRITE(kwlun) kngx1, kngy1, kngx2, kngy2
+C
+C* Job is done
+C
+          IF (nlogprt .GE. 2) THEN  
+              CALL prtout('Wrote weights on unit = ', kwlun, 1) 
+          ENDIF
+C
+C* Reading
+C  -------
+C
+        ELSE
+C
+C
+C* Reads weights and checks  
+C
+C* - Read main locator string + weights
+          CALL locread (clweight, pr1to2, kw1to2*kngx2*kngy2, 
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C
+C* - Read overlapped neighbors adresses
+C
+          CALL locrint (cladress, k1to2, kw1to2*kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C
+C* - Read overlapped neighbors numbers
+C
+          CALL locrint (cloverlp, kmskz2, kngx2*kngy2,
+     $                   kwlun, iflag)
+          IF (iflag .NE. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', kwlun
+              WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cloverlp
+              CALL HALTE ('Stop in namset')
+          ENDIF
+C
+C* - Read  checkings numbers (grid parameters)
+C
+          READ(kwlun) ingx1, ingy1, ingx2, ingy2
+C
+C* Checks
+C
+          IF (ingx1 .NE. kngx1 .OR. ingy1 .NE. kngy1 .OR. 
+     $        ingx2 .NE. kngx2 .OR. ingy2 .NE. kngy2) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' Inconsistency in mweights file'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingx1 = ',ingx1,'kngx1 = ',kngx1
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingy1 = ',ingy1,'kngy1 = ',kngy1
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingx2 = ',ingx2,'kngx2 = ',kngx2
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'ingy2 = ',ingy2,'kngy2 = ',kngy2
+              CALL HALTE ('Stop in namset')
+          ENDIF 
+C
+C* Reading of weights done
+C
+          IF (nlogprt .GE. 2) THEN 
+              CALL prtout
+     $        ('Reading of weights done on unit = ', kwlun, 1) 
+          ENDIF
+      ENDIF
+C
+C
+C*    6. Printing weights and adresses on ANAIS output file
+C        --------------------------------------------------
+C
+      IF (nlogprt .GE. 2) THEN 
+          WRITE (UNIT = nulan,FMT = *) ' '
+          WRITE (UNIT = nulan,FMT = *) 
+     $    ' Print weights and adresses of overlapped neighbors '
+          WRITE (UNIT = nulan,FMT = *)
+     $    ' ************************************************** '
+          WRITE (UNIT = nulan,FMT = *) ' '
+          DO 610 jj = 1, kngy2 
+            DO 620 ji = 1, kngx2
+              WRITE (UNIT = nulan,FMT = 6010) ji, jj
+              WRITE (UNIT = nulan,FMT = 6020) px2(ji,jj), py2(ji,jj)
+              WRITE (UNIT = nulan,FMT = 6030) kmskz2(ji,jj)
+              IF (kmskz2(ji,jj) .NE. 0) THEN
+                  IF (kmsk2(ji,jj) .EQ. 0) THEN 
+                      DO 630 jn = 1, kmskz2(ji,jj)
+                        iind = ji + kngx2 * (jj-1)
+                        iadr = k1to2(jn,iind)
+                        ix = icoor(iadr,kngx1)
+                        iy = jcoor(iadr,kngx1)
+                        WRITE(UNIT = nulan,FMT = 6040) 
+     $                  jn, pr1to2(jn,iind)
+                        WRITE(UNIT = nulan,FMT = 6050) 
+     $                  ix, iy, px1(ix,iy), py1(ix,iy)
+ 630                  CONTINUE 
+                  ELSE
+                      WRITE(UNIT = nulan,FMT = 6060)
+                  ENDIF 
+              ENDIF
+ 620        CONTINUE
+ 610      CONTINUE 
+          CALL FLUSH(nulan)
+      ENDIF
+C
+C* Formats
+C
+ 6010 FORMAT(/,' Target grid point --  i = ',I3,' j = ',I3)
+ 6020 FORMAT(' Point coordinates -- long = ',F9.4,' lat = ',F9.4)
+ 6030 FORMAT(3X,'Number of overlapped source grid squares = ',I3)
+ 6040 FORMAT(5X,' neighbor number = ',I3,' weight is = ',F6.4)
+ 6050 FORMAT(5X,' i = ',I3,' j = ',I3,' lon = ',F9.4,' lat = ',F9.4)
+ 6060 FORMAT(5X,' This is a continental point on the target grid ')
+C
+C
+C*    7. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine namset ---------'
+          CALL FLUSH(nulou)
+      ENDIF
+      RETURN
+      END
+
+
+
+
Index: CPL/oasis3/trunk/src/lib/anaism/src/namsst.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/namsst.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/namsst.f	(revision 1677)
@@ -0,0 +1,118 @@
+      SUBROUTINE namsst (pflda, kmska, kvmska, kngxa, kngya,
+     $                   prbtoa, kbtoa, kwbtoa,
+     $                   pfldb, kngxb, kngyb)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *namsst* -  Interpolation  Anaism method 
+C
+C     Purpose:
+C     -------
+C     Performs subgrid averaged interpolation
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *namsst(pflda, kmska, kvmska, kngxa, kngya,
+C                       prbtoa, kbtoa, kwbtoa,
+C                       pfldb, kngxb, kngyb)*
+C
+C     Input:
+C     -----
+C                kmska  : mask for target grid (integer 2D)
+C                kvmska : the value of the mask for target grid
+C                kngxa  : number of longitudes for target grid
+C                kngya  : number of latitudes for target grid
+C                prbtoa : weights for Anaism interpolation (real 2D)
+C                kbtoa  : source grid neighbors adresses (integer 2D)
+C                kwbtoa : maximum number of overlapped neighbors
+C                pfldb  : field on source grid (real 2D)
+C                kngxb  : number of longitudes for source grid
+C                kngyb  : number of latitudes for source grid
+C
+C     Output:
+C     ------
+C                pflda: field on target grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     plsst
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C     
+      REAL (kind=ip_realwp_p) pflda(kngxa,kngya), pfldb(kngxb,kngyb)
+      REAL (kind=ip_realwp_p) prbtoa(kwbtoa,kngxb*kngyb)
+      INTEGER (kind=ip_intwp_p) kmska(kngxa,kngya), 
+     $    kbtoa(kwbtoa,kngxb*kngyb)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '           ROUTINE namsst  -  Level 3'
+          WRITE(UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) 
+     $    ' Perform ANAIS-MESH interpolation'
+          WRITE(UNIT = nulou,FMT = *) ' '
+          WRITE(UNIT = nulou,FMT = *) ' '
+      ENDIF
+      inga = kngxa *kngya
+      ingb = kngxb *kngyb
+C
+C
+C*    2. Call interpolator
+C        -----------------
+C
+      CALL plsst (pflda, prbtoa, kbtoa, kwbtoa, inga, pfldb,
+     $            ingb, kmska, kvmska)
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine namsst ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaism/src/pcssph.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/pcssph.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/pcssph.f	(revision 1677)
@@ -0,0 +1,131 @@
+      SUBROUTINE pcssph (px, py, psgr, kngx, kngy)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL T *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pcssph* -  Arithmetic routine
+C
+C     Purpose:
+C     -------
+C     Calculate surface element for a spheric and periodic grid.
+C     The coordinates are in degrees, there are no pole points.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *pcssph(px, py, psgr, kngx, kngy)*
+C
+C     Input:
+C     -----
+C                px   : grid longitudes (real 2D)
+C                py   : grid latitudes (real 2D)
+C                kngx : number of longitudes
+C                kngy : number of latitudes
+C
+C     Output:
+C     ------
+C                psgr : grid surface elements (real 2D)
+C
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C     
+      REAL (kind=ip_realwp_p) px(kngx,kngy), py(kngx,kngy)
+      REAL (kind=ip_realwp_p) psgr(kngx,kngy)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Degres to radians conversion factor
+C        -----------------------------------
+C
+      zconv = 1.74532925199432957692e-2
+C
+C
+C*    2. Surfaces 
+C        --------
+C
+      DO 210 j2 = 1, kngy
+        DO 220 j1 = 1, kngx
+C
+C* Left or right periodicity
+C
+          IF (J1 .EQ. 1) THEN
+              zx1 = px(kngx,j2) - 360.
+              zx2 = px(2,j2)
+            ELSE IF (j1 .EQ. kngx)  THEN
+              zx1 = px(kngx-1,j2)
+              zx2 = px(1,j2) + 360.
+            ELSE
+              zx1 = px(j1-1,j2)
+              zx2 = px(j1+1,j2)
+          ENDIF
+C
+C* Bottom or top treatment
+C
+          IF (j2 .EQ. 1) THEN
+              zy1 = -90.
+              zy2 = .5 * (py(j1,j2) + py(j1,j2+1))
+            ELSE IF (j2 .EQ. kngy) THEN
+              zy1 = .5 * (py(j1,j2) + py(j1,j2-1))
+              zy2 = 90.
+            ELSE 
+              zy1 = .5 * (py(j1,j2) + py(j1,j2-1))
+              zy2 = .5 * (py(j1,j2) + py(j1,j2+1))
+          ENDIF
+C
+C* Conversion to radians
+C
+          zfi1 = zx1 * zconv
+          zfi2 = zx2 * zconv
+          zth1 = zy1 * zconv
+          zth2 = zy2 * zconv
+C
+C* Calculate grid square surface
+C   
+          zfac = sin(zth2) - sin(zth1) 
+          psgr(j1,j2) = abs(.5 * (zfi2-zfi1) * zfac)      
+ 220    continue
+ 210  CONTINUE
+C
+C* End of routine
+C
+      RETURN 
+      END
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/lib/anaism/src/plsst.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/plsst.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/plsst.f	(revision 1677)
@@ -0,0 +1,99 @@
+       SUBROUTINE plsst (pqta, prho, kto, kwg, knga, pqtb,
+     $                   kngb, kmska, kvma)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *plsst* -  Perform subgrid interpolation through Anaism method 
+C
+C     Purpose:
+C     -------
+C     Given the weights prho and indices kto for field pqtb, performs
+C     a surface ponderation to generate field pqta on target grid.
+C 
+C     N.B: Nothing is done for the masked points
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *plsst(pqta, prho, kto, kwg, knga, pqtb,
+C                      kngb, kmska, kvma)*
+C
+C     Input:
+C     -----
+C                kmska : mask for target grid (integer 1D)
+C                kvma  : the value of the mask for target grid
+C                knga  : number of points for target grid
+C                prho  : weights for Anaism interpolation (real 2D)
+C                kto   : source grid neighbors adresses (integer 2D)
+C                kwg   : maximum number of overlapped neighbors
+C                pqtb  : field on source grid (real 1D)
+C                kngb  : number of points for source grid
+C
+C     Output:
+C     ------
+C                pqta  : field on target grid (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pqtb(kngb), pqta(knga), prho(kwg,knga)
+      INTEGER (kind=ip_intwp_p) kmska(knga), kto(kwg,knga)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*     1. Ponderation
+C         -----------
+C* Loop over all target grid points
+C
+      DO 110 j1 = 1, knga
+C
+C* Nothing happens if it is a continental point
+C
+        IF (kmska(j1) .NE. kvma) THEN 
+            zsum = 0.
+C
+C* Ponderation over all overlapped source grid neighbors 
+C
+            DO 120 j2 = 1, kwg
+              zsum = zsum + prho(j2,j1) * pqtb(kto(j2,j1))
+ 120        CONTINUE
+            pqta(j1) = zsum
+        ENDIF
+ 110  CONTINUE
+C
+C* End of routine
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/anaism/src/pmesh.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/pmesh.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/pmesh.f	(revision 1677)
@@ -0,0 +1,135 @@
+      SUBROUTINE pmesh (kx, ky, px, py, kngx, kngy, cdper, kper,
+     $                  pxi, pxs, pyi, pys)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pmesh* -  Calculate the mesh controlled by one point on a
+C               periodical or non-periodical grid.
+C
+C     Purpose:
+C     -------
+C     For one point defined by the coordinates (px(k),py(k)) 
+C     on a lat-lon grid, gives the inferior and superior longitudes 
+C     (pxi,pxs) and latitudes (pyi,pys) of the associated mesh.
+C     
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *pmesh(kx, ky, px, py, kngx, kngy, cdper, kper,
+C                      pxi, pxs, pyi, pys)*
+C
+C     Input:
+C     -----
+C                kx    : point longitude index
+C                ky    : point latitude index
+C                px    : longitude array (real 2D)
+C                py    : latitude array (real 2D)
+C                kngx  : number of longitudes
+C                kngy  : number of latitudes
+C                cdper : grid periodicity
+C                kper  : number of overlapped points
+C
+C     Output:
+C     ------
+C                pxi  : inferior longitude
+C                pxs  : superior longitude
+C                pyi  : inferior latitude
+C                pys  : superior latitude
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px(kngx,kngy), py(kngx,kngy)
+      CHARACTER*8 cdper
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Left or right 
+C        -------------
+C
+C* Periodic grid with kper overlapped points
+C 
+      IF (cdper .EQ. 'P') THEN
+          IF (kx .EQ. 1) THEN
+              pxi = 0.5 * (px(kx,ky) + px(kngx-kper,ky) - 360.)
+              pxs = 0.5 * (px(kx,ky) + px(kx+1,ky))
+             ELSE IF (kx .EQ. kngx) THEN
+              pxi = 0.5 * (px(kx-1,ky) + px(kx,ky))
+              pxs = 0.5 * (px(kx,ky) + px(1+kper,ky) + 360. )
+            ELSE
+              pxi = 0.5 * (px(kx-1,ky) + px(kx,ky))
+              pxs = 0.5 * (px(kx,ky) + px(kx+1,ky))           
+          ENDIF
+C      
+C* Regional grid
+C 
+        ELSE IF (cdper .EQ. 'R') THEN
+          IF (kx .EQ. 1) THEN
+              pxi = px(kx,ky)
+              pxs = 0.5 * (px(kx,ky) + px(kx+1,ky))
+            ELSE IF (kx .EQ. kngx) THEN
+              pxi = 0.5 * (px(kx-1,ky) + px(kx,ky))
+              pxs = px(kx,ky)
+            ELSE
+              pxi = 0.5 * (px(kx-1,ky) + px(kx,ky))
+              pxs = 0.5 * (px(kx,ky) + px(kx+1,ky))
+          ENDIF
+      END IF
+C
+C
+C*    2. Bottom or top (idem for both types of grid) 
+C        -------------------------------------------
+C True only if it is a global grid in latitude [-90 , 90]
+C or as it is the case for regional models if the first and last 
+C latitude row are masked ---> then we only go through the else statement.
+C
+      IF (ky .EQ. 1) THEN
+          pyi = -90.
+          pys = 0.5 * (py(kx,ky) + py(kx,ky+1))
+        ELSE IF (ky .EQ. kngy) THEN
+          pyi = 0.5 * (py(kx,ky-1) + py(kx,ky))
+          pys = 90.
+        ELSE
+          pyi = 0.5 * (py(kx,ky-1) + py(kx,ky))
+          pys = 0.5 * (py(kx,ky)+ py(kx,ky+1))
+      ENDIF
+C
+C* End of routine
+C
+      RETURN
+      END
+
Index: CPL/oasis3/trunk/src/lib/anaism/src/pminm.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/pminm.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/pminm.f	(revision 1677)
@@ -0,0 +1,226 @@
+      SUBROUTINE pminm (kflag, psurf,
+     $                  p2xi, p2xs, p2yi, p2ys,
+     $                  p1xi, p1xs, p1yi, p1ys)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pminm* -  calculate intersection between two meshes
+C
+C     Purpose:
+C     -------
+C     For two meshes defined by their inf. and sup. latitude and
+C     longitude (p1xi,p1xs,p1yi,p1ys) and (p2xi,p2xs,p2yi,p2ys), checks
+C     if they have any intersection and calculates the surface, psurf, 
+C     of that intersection. The 2 grids considered may be periodic
+C     or non-periodic.
+C
+C     N.B: Intersection surface is given by the following formula:
+C          Si = r*r * (sin(lat2)-sin(lat1)) * (phi2-phi1)
+C              with lat2, lat1 sup. and inf. latitudes
+C                   phi2, phi1 sup. and inf. longitudes
+C          This results from the integration of dS=r*r*cos(lat)*d(lat)*d(phi)
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *pminm(kflag, psurf,
+C                      p2xi, p2xs, p2yi, p2ys,
+C                      p1xi, p1xs, p1yi, p1ys)*
+C
+C     Input:
+C     -----
+C                p2xi  : target grid square inferior longitude
+C                p2xs  : target grid square superior longitude
+C                p2yi  : target grid square inferior latitude
+C                p2ys  : target grid square superior latitude
+C                p1xi  : source grid square inferior longitude
+C                p1xs  : source grid square superior longitude
+C                p1yi  : source grid square inferior latitude
+C                p1ys  : source grid square superior latitude
+C
+C     Output:
+C     ------
+C                psurf  : the intersection's surface
+C                kflag  : 1 if intersection is not empty, 0 otherwise
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     None
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      kflag = 0
+      psurf = 0.
+      z2pi = 2. * acos(-1.)
+      zconv = 1.74532925199432957692e-2
+C
+C* Assign local variables
+C
+      zfi1i = p1xi
+      zfi1s = p1xs
+      zfi2i = p2xi
+      zfi2s = p2xs
+C
+C* Put longitudes in the [0-360] interval to avoid problem in 
+C  surface calculation.
+C
+      IF (p1xi .GE. 360.0) zfi1i = zfi1i - 360.0
+      IF (p1xi .LT. 0. ) zfi1i = zfi1i + 360.0
+      IF (p1xs .GT. 360.0) zfi1s = zfi1s - 360.0
+      IF (p1xs .LE. 0. ) zfi1s = zfi1s + 360.0
+      IF (p2xi .GE. 360.0) zfi2i = zfi2i - 360.0
+      IF (p2xi .LT. 0. ) zfi2i = zfi2i + 360.0
+      IF (p2xs .GT. 360.0) zfi2s = zfi2s - 360.0
+      IF (p2xs .LE. 0. ) zfi2s = zfi2s + 360.0
+C
+C* Conversion degrees to radians
+C
+      zfi1i = zfi1i * zconv
+      zfi1s = zfi1s * zconv
+      zth1i = p1yi * zconv
+      zth1s = p1ys * zconv
+      zfi2i = zfi2i * zconv
+      zfi2s = zfi2s * zconv
+      zth2i = p2yi * zconv
+      zth2s = p2ys * zconv
+C
+C
+C*    2. Check and calculation of intersection
+C        -------------------------------------
+C
+C* Check of latitudinal intersection
+C 
+      IF (zth2s .GT. zth1i .AND. zth2i .LT. zth1s) THEN
+C
+C* Calculate the delta(latitude)
+C
+C* Latitude inf.
+C
+          zlati = amax1(zth2i,zth1i)
+C
+C* Latitude sup.
+C
+          zlats = amin1(zth2s,zth1s)
+C
+C* sin(lat_sup) - sin(lat_inf)
+C
+          zdth = sin(zlats) - sin(zlati)
+C
+C* Check of longitudinal intersection
+C
+          zfi1ir = zfi1i - z2pi
+          zfi2ir = zfi2i - z2pi
+          zfi2sr = zfi2s - z2pi
+C   
+C* Case of a mesh 1 whose minimal longitude zfi1i is less than the
+C  maximal one zfi1s (normal case). The opposite can occur only for
+C  a periodic grid.
+C 
+          IF (zfi1i .LT. zfi1s) THEN
+C
+C - Check if it is similar for mesh 2
+C
+              IF (zfi2i .LT. zfi2s) THEN
+C
+C - If yes, find the intersection
+C
+                  IF (zfi2s .GT. zfi1i .AND. zfi2i .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = amin1(zfi2s,zfi1s) - amax1(zfi2i,zfi1i)
+                      psurf = zdth * zdfi
+                  ENDIF
+C
+C - If not, mesh 2 is periodic
+C
+                ELSE IF (zfi2i .GT. zfi2s) THEN
+C
+C - Find intersection in that case
+C 
+                  IF (zfi2s .GT. zfi1i .AND. zfi2ir .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = amin1(zfi2s,zfi1s) - zfi1i
+                      psurf = zdth * zdfi
+                  ENDIF
+                  IF (zfi2s .GT. zfi1ir .AND. zfi2i .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = amin1(zfi2i,zfi1s) - zfi1i
+                      psurf = zdth * zdfi
+                  ENDIF
+              ENDIF
+          ENDIF
+C
+C* Case of a mesh 1 whose minimal longitude zfi1i is located
+C  on the right of the grid and whose maximum longitude zfi1s
+C  is on the left of the grid. This occurs only for a periodic mesh
+C 
+          IF (zfi1i .GT. zfi1s) THEN
+C
+C - Check for mesh 2
+C
+              IF (zfi2i .LT. zfi2s) THEN
+C
+C - Find intersection
+C
+                  IF (zfi2s .GT. zfi1ir .AND. zfi2i .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = amin1(zfi2s,zfi1s) - zfi2i
+                      psurf = zdth * zdfi 
+                    ELSE IF (zfi2sr .GT. zfi1ir .AND. 
+     $                    zfi2ir .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = zfi2s - amin1(zfi2i,zfi1i)
+                      psurf = zdth * zdfi
+                  ENDIF
+C
+C - Mesh 2 is periodic
+C
+                ELSE IF (zfi2i .GT. zfi2s) THEN 
+C
+C - Find intersection
+C
+                  IF (zfi2s .GT. zfi1ir .AND. zfi2ir .LT. zfi1s) THEN
+                      kflag = 1
+                      zdfi = amin1(zfi2s,zfi1s) - amax1(zfi2ir,zfi1ir)
+                      psurf = zdth * zdfi 
+                  ENDIF
+              ENDIF 
+          ENDIF
+      ENDIF
+C
+C* End of routine
+C
+      RETURN 
+      END
+
Index: CPL/oasis3/trunk/src/lib/anaism/src/pmrhal.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/pmrhal.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/pmrhal.f	(revision 1677)
@@ -0,0 +1,138 @@
+      SUBROUTINE pmrhal (pr1to2, k1to2, kw1to2,
+     $                   px1, py1, kmsk1, kngx1, kngy1, cdper1, kper1,
+     $                   px2, py2, kmsk2, kngx2, kngy2, cdper2, kper2,
+     $                   kvma1, kvma2, kmskz2, kvmsz2)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pmrhal* - Calculate weights and adresses for all the target grid 
+C
+C     Purpose:
+C     -------
+C     For each point of a target grid 2 give the kw1to2 closest neighbours 
+C     adresses k1to2 in source grid 1 and their weight pr1to2. 
+C     Here, neighbours are those in the mesh overlapped by each target point
+C     and weights are proportional to the surface mesh intersections. 
+C     2D grid assumptions are made here.
+C     
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *pmrhal(pr1to2, k1to2, kw1to2,
+C                       px1, py1, kmsk1, kngx1, kngy1, cdper1, kper1,
+C                       px2, py2, kmsk2, kngx2, kngy2, cdper2, kper2,
+C                       kvma1, kvma2, kmskz2, kvmsz2)*
+C     Input:
+C     -----
+C                kw1to2  : maximum number of overlapped neighbors
+C                px1     : longitudes for source grid (real 2D)
+C                py1     : latitudes for source grid (real 2D)
+C                kmsk1   : the mask for source grid (integer 2D)
+C                kngx1   : number of longitudes for source grid
+C                kngy1   : number of latitudes for source grid
+C                cdper1  : source grid periodicity 
+C                kper1   : number of overlapped points for source grid 
+C                px2     : longitudes for target grid (real 2D)
+C                py2     : latitudes for target grid (real 2D)
+C                kmsk2   : the mask of target grid (integer 2D)
+C                kngx2   : number of longitudes for target grid
+C                kngy2   : number of latitudes for target grid
+C                cdper2  : target grid periodicity
+C                kper2   : number of overlapped points for target grid 
+C                kvma1   : the value of the mask for source grid
+C                kvma2   : the value of the mask for target grid 
+C                kvmsz2  : mask value for array kmskz2
+C
+C     Output:
+C     ------
+C                pr1to2  : weights for Anaism interpolation (real 3D)
+C                k1to2   : source grid neighbors adresses (integer 3D)
+C                kmskz2  : number of source grid neighbors (integer 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     pmesh, pmrho
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px1(kngx1,kngy1), py1(kngx1,kngy1)
+      REAL (kind=ip_realwp_p) px2(kngx2,kngy2), py2(kngx2,kngy2)
+      REAL (kind=ip_realwp_p) pr1to2(kw1to2,kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx1,kngy1), kmsk2(kngx2,kngy2)
+      INTEGER (kind=ip_intwp_p) k1to2(kw1to2,kngx2,kngy2), 
+     $    kmskz2(kngx2,kngy2)
+      CHARACTER*8 cdper1, cdper2
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Neighbours determination
+C        ------------------------
+C 
+      DO 110 jy = 1, kngy2
+        DO 120 jx = 1, kngx2
+C
+C* For all target grid points:  zero all weights and set adresses to one
+C 
+          DO 130 jwg = 1, kw1to2
+            pr1to2(jwg,jx,jy) = 0.
+            k1to2(jwg,jx,jy) = 1 
+ 130      CONTINUE
+C
+C* Calculate the surface of all the target grid squares (masked or not)
+C
+          CALL pmesh (jx, jy, px2, py2, kngx2, kngy2, cdper2, kper2,
+     $                z2xi, z2xs, z2yi, z2ys)
+C
+C* Calculate the neighbors in the source grid and their weights
+C
+          CALL pmrho (pr1to2(1,jx,jy), k1to2(1,jx,jy), kw1to2,
+     $                z2xi, z2xs, z2yi, z2ys,
+     $                px1, py1, kmsk1, kngx1, kngy1, cdper1, kper1,
+     $                kvma1, kmskz2(jx,jy), kvmsz2)
+C
+C* For masked points: 
+C
+          IF (kmsk2(jx,jy) .EQ. kvma2) THEN
+              DO 140 jwg = 1, kw1to2
+                pr1to2(jwg,jx,jy) = 0.
+                k1to2(jwg,jx,jy) = 1 
+ 140          CONTINUE
+          ENDIF
+ 120    CONTINUE
+ 110  CONTINUE 
+C
+C* End of routine
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/anaism/src/pmrho.f
===================================================================
--- CPL/oasis3/trunk/src/lib/anaism/src/pmrho.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/anaism/src/pmrho.f	(revision 1677)
@@ -0,0 +1,214 @@
+      SUBROUTINE pmrho (prho, kto, kwg,
+     $                  p2xi, p2xs, p2yi, p2ys,
+     $                  px1, py1, kmsk1, kngx, kngy, cdper, kper,
+     $                  kvma1, kmsz2, kvmsz2)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pmrho* - Calculate weights and adresses at one location 
+C     
+C     Purpose:
+C     -------
+C     At one target grid location, gives the kwg closest neighbours 
+C     adresses kto in source grid and their weight prho, which is function of
+C     the surface intersection (if no overlap, weight is zero).
+C
+C     N.B: Note that the search is done ONLY over unmasked points. 
+C 
+C**   Interface:
+C     ---------
+C       *CALL*  *pmrho(prho, kto, kwg,
+C                      p2xi, p2xs, p2yi, p2ys,
+C                      px1, py1, kmsk1, kngx, kngy, cdper, kper,
+C                      kvma1, kmsz2, kvmsz2)* 
+C
+C     Input:
+C     -----
+C                kwg   : maximum number of overlapped neighbors
+C                p2xi  : the inf longitude of the target grid square
+C                p2xs  : the sup longitude of the target grid square
+C                p2yi  : the inf latitude of the target grid square
+C                p2ys  : the sup latitude of the target grid square
+C                px1   : longitudes for source grid (real 2D)
+C                py1   : latitudes for source grid (real 2D)
+C                kmsk1 : the mask for source grid (integer 2D)
+C                kngx  : number of longitudes for source grid
+C                kngy  : number of latitudes for source grid
+C                kvma1 : the value of the mask for source grid
+C                cdper : source grid periodicity 
+C                kper  : number of overlapped points for source grid
+C     Output:
+C     ------
+C                prho  : the neighbors weights 
+C                kto   : the neighbors adresses in the source grid 
+C                kmsz2 : number of source grid neighbors (integer 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     External:
+C     --------
+C     pmesh, pminm
+C
+C     References:
+C     ----------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      ----------- 
+C       1.1       O. Thual       93/04/15  created 
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.3       L. Terray      99/09/15  changed periodicity variable
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) px1(kngx,kngy), py1(kngx,kngy)
+      REAL (kind=ip_realwp_p) prho(kwg)
+      INTEGER (kind=ip_intwp_p) kmsk1(kngx,kngy)
+      INTEGER (kind=ip_intwp_p) kto(kwg)
+      CHARACTER*8 cdper
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Various initializations
+C        -----------------------
+C 
+      ivma1 = kvma1
+      ing = kngx * kngy
+C
+C   
+C*    2. Neighbors (mesh) determination
+C        -------------------------------
+C* Checks
+C     
+      IF (kwg .GT. ing) THEN
+          WRITE(UNIT = nulou,FMT = *) 
+     $        'WARNING in pmrho -- kwg = ',kwg,' .gt. ing = ',ing
+          WRITE(UNIT = nulou,FMT = *) 
+     $        ' Number of searched neighbors greater '
+          WRITE(UNIT = nulou,FMT = *) 
+     $        ' than number of grid points '
+          iwg = ing
+          WRITE(UNIT = nulou,FMT = *)  'We set  iwg = ing = ',iwg
+        ELSE
+          iwg = kwg
+      ENDIF
+C
+C* zero the weights and set adresses to one
+C
+      CALL szero(prho,iwg)
+      DO 210 ji = 1, iwg
+        kto(ji) = 1
+ 210  CONTINUE
+C
+C* Loop on all the points of source grid  
+C
+      iwco = 0
+      DO 220 jy = 1, kngy
+        DO 230 jx = 1, kngx
+C
+C* If it is an unmasked point
+C
+          IF (kmsk1(jx,jy) .NE. ivma1) THEN
+C
+C* Calculate its grid square longitude and latitude extrema
+C
+              CALL pmesh (jx, jy, px1, py1, kngx, kngy, cdper, kper,
+     $                    z1xi, z1xs, z1yi, z1ys)
+C
+C* Determine the intersection with the current target grid square
+C
+              CALL pminm (iflag, zsurf,
+     $                    p2xi, p2xs, p2yi, p2ys,
+     $                    z1xi, z1xs, z1yi, z1ys)
+C
+C* If intersection is not empty
+C
+              IF (iflag .EQ. 1) THEN
+                  iwco = iwco +1
+C
+C* Check dimensions
+C
+                  IF (iwco .GT. iwg) THEN 
+                      WRITE(UNIT = nulou,FMT = *)  
+     $                    ' WARNING: not enough neighbours space'
+                      WRITE(UNIT = nulou,FMT = *) 
+     $                    ' ******* '
+                      WRITE(UNIT = nulou,FMT = *) 
+     $                    ' In pmrho : iwco = ',iwco,'.gt.iwg = ',iwg
+                      CALL HALTE('STOP in pmrho')
+                    ELSE
+C
+C* Get index adress and surface overlap for neighbor number iwco
+C
+                      kto(iwco) = jx + (jy-1) * kngx
+                      prho(iwco) = zsurf
+                  ENDIF
+              ENDIF
+          ENDIF
+ 230    CONTINUE 
+ 220  CONTINUE
+C
+C
+C*    3. Weight function
+C        ---------------
+C
+C* Sum of the surface values
+C
+      zsum = 0.
+      DO 310 jwg = 1, iwg
+        zsum = zsum + prho(jwg)
+ 310  CONTINUE
+C
+C* Normalization
+C
+      zthres = 1.e-6
+C
+C* If no intersection is found, point is masked in overlapping array
+C
+      IF (iwco .EQ. 0) THEN
+          kmsz2 = kvmsz2
+C
+C* If at least one intersection is found
+C     
+        ELSE
+          kmsz2 = iwco
+C
+C* If under threshold
+C   
+          IF (zsum .LT. zthres) THEN
+              DO 320 jwg = 1, iwg
+                prho(jwg) = 1. / float(iwco)
+ 320          CONTINUE
+C
+C* If above threshold, normalize
+C
+            ELSE
+              DO 330 jwg = 1, iwg
+                prho(jwg) = prho(jwg) / zsum
+ 330          CONTINUE
+          ENDIF
+      ENDIF
+C
+C* End of routine
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Export.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Export.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Export.F	(revision 1677)
@@ -0,0 +1,175 @@
+      SUBROUTINE CLIM_Export(id_port_id,kstep,pfield,kinfo)
+c
+c*    *** Export ***   
+c
+c     purpose:
+c     --------
+c        give pfield to models connected to port id_port_id  at the time kstep
+c
+c     interface:
+c     ----------
+c        id_port_id : port number of the field
+c	 kstep	: current time in seconds
+c	 pfield	: buffer of reals
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-1
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.     
+c        Arnaud Caubel  - Fecit
+c
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       kstep, kinfo
+      CHARACTER(len=1), DIMENSION(*) :: pfield
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)    info
+      INTEGER (kind=ip_intwp_p)	   isend, ip, iport, ilk, iseg, is, 
+     $    ilgb, imod, itid, itag, ilen, ioff, ityp, ibyt
+      INTEGER (kind=ip_intwp_p)    iposbuf
+c     ----------------------------------------------------------------
+c
+c*    0. First Check
+c     --------------
+c
+      WRITE(nulprt, *)'entering CLIM_Export'
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Export - should not be called'
+          GO TO 1010
+      ENDIF
+      kinfo = CLIM_Ok
+c
+c*    1. check for this port in my list
+c     ---------------------------------
+c
+      isend = 0
+      iport = -1
+c
+      IF (myport(1,id_port_id).eq.CLIM_Out) iport=id_port_id
+
+      IF (iport.lt.0) THEN
+         kinfo = CLIM_BadPort
+         WRITE(nulprt,FMT='(A,A)')
+     *         'Export - WARNING - Invalid port out: ',
+     $        cports(id_port_id)
+         GO TO 1010
+      ENDIF
+c
+c*    2. check for connected ports (in)
+c     ---------------------------------
+c
+      WRITE(nulprt,FMT='(A,A)') 'Export - ', cports(iport)
+c
+      ityp = myport(2,iport)
+      ibyt = myport(3,iport)
+c
+      DO 290 ip=1,myport(5,iport)
+c
+         ilk  = myport(5+ip,iport)
+         imod = mylink(1,ilk)
+         itid = mylink(2,ilk)
+         itag = mylink(3,ilk) - kstep / ig_frqmin
+         iseg = mylink(4,ilk)
+c
+             ilgb = 0
+             iposbuf = 0
+             DO 240 is=1,iseg
+               ioff = mylink(4+2*is-1,ilk) * ibyt + 1
+               ilen = mylink(4+2*is,ilk)
+c
+c               IF     ( ityp .EQ. CLIM_Integer ) THEN
+c                   CALL MPI_Pack ( pfield(ioff), ilen, MPI_INTEGER, 
+c     *                 pkwork, ig_maxtype, iposbuf, mpi_comm, info )
+c               ELSEIF ( ityp .EQ. CLIM_Real ) THEN
+               IF ( ityp .EQ. CLIM_Real ) THEN
+C                   IF ( kind(rl_testvar) .eq. 4 ) THEN
+                   IF ( ip_realwp_p .eq. ip_single_p ) THEN
+                       CALL MPI_Pack ( pfield(ioff), ilen, 
+     *                     MPI_REAL,pkwork, ig_maxtype, iposbuf, 
+     *                     mpi_comm, info )
+C                   ELSE IF ( kind(rl_testvar) .eq. 8 ) THEN
+                   ELSE IF ( ip_realwp_p .eq. ip_double_p ) THEN
+                       CALL MPI_Pack ( pfield(ioff), ilen, 
+     *                     MPI_DOUBLE_PRECISION,pkwork, ig_maxtype, 
+     *                     iposbuf, mpi_comm, info )
+                   ENDIF
+c               ELSEIF ( ityp .EQ. CLIM_Double ) THEN
+c                   CALL MPI_Pack ( pfield(ioff), ilen, 
+c     *                 MPI_DOUBLE_PRECISION,
+c     *                 pkwork, ig_maxtype, iposbuf, mpi_comm, info )
+               ELSE
+                   WRITE(nulprt,*)'Export - pb type incorrect ',ityp
+		   kinfo = CLIM_BadType
+                   GO TO 1010
+               ENDIF
+               ilgb = ilgb + ilen
+ 240        CONTINUE
+            IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype) THEN
+               kinfo = CLIM_Pack
+               WRITE(nulprt,FMT='(A,I3,I8,A)')
+     *              'Export - pb pack<mpi ',info,ilgb*ibyt,'>'
+            ELSE
+c
+                IF (lg_bsend) then
+c*
+c*   Buffered send
+c*   -> if fields are not sent and received in the same order, and
+c*   and on architectures on which MPI_Send is not implemented with a 
+c*   mailbox (e.g. NEC SX5)
+c*
+                    CALL MPI_BSend ( pkwork, iposbuf, MPI_PACKED, itid,
+     *                  itag, mpi_comm, info )
+                ELSE
+c
+c*   Standard blocking send: To be used
+c*   -> if fields are necessarily sent and received in the same order, 
+c*   -> or on architectures on which MPI_Send is implemented with a 
+c*      mailbox (e.g. VPPs); in this case, make sure that your mailbox
+c*      size is large enough.
+c
+                    CALL MPI_Send ( pkwork, iposbuf, MPI_PACKED, itid,
+     *                  itag, mpi_comm, info )
+c
+                ENDIF
+c
+                 IF (info.eq.CLIM_ok) THEN
+                     isend = isend + 1
+                     nbsend = nbsend + ilgb * ibyt
+                     WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)')
+     *                   'Export - <dest:',imod,
+     *                   '> <step:',kstep,
+     *                   '> <len:',ilgb,
+     *                   '> <type:',ibyt,
+     *                   '> <tag:',itag,'>'
+                 ELSE
+                     kinfo = CLIM_Pvm
+                     WRITE(nulprt,FMT='(A,I3,A)')
+     *                   'Export - pb send <mpi ',info,'>'
+                 ENDIF
+             ENDIF
+c
+c
+ 290    CONTINUE
+c
+        WRITE(nulprt,FMT='(A,I3,A)') 
+     *     'Export - ',isend,' fields exported'
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CALL FLUSH(nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Import.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Import.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Import.F	(revision 1677)
@@ -0,0 +1,197 @@
+      SUBROUTINE CLIM_Import(id_port_id,kstep,pfield,kinfo)
+c
+c*    *** Import ***   
+c
+c     purpose:
+c     --------
+c        recv pfield from models connected to port id_port_id
+c
+c     interface:
+c     ----------
+c        id_port_id : port number of the field
+c	 kstep	: current time in seconds
+c	 pfield	: buffer of reals
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-1
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E. 
+c        Arnaud Caubel  - Fecit
+c
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       kstep, kinfo
+      CHARACTER(len=1), DIMENSION(*) :: pfield      
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)     i4kstep
+      INTEGER (kind=ip_intwp_p)     info
+      INTEGER (kind=ip_intwp_p)	    irecv, imod, ilk, iseg, is, ilgb,
+     $    itid, itag, ilen, ioff, ityp, ibyt
+      INTEGER (kind=ip_intwp_p)     iposbuf, istatus(MPI_STATUS_SIZE), 
+     $    imaxbyt
+c
+#ifdef __DEBUG
+      INTEGER(kind=ip_intwp_p)     icount
+      INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
+      LOGICAL                      iflag
+#endif
+c     ----------------------------------------------------------------
+c
+c*    0. First Check
+c     --------------
+c
+      i4kstep = kstep
+      istatus(:)=0
+c
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Import - should not be called'
+          GO TO 1010
+      ENDIF
+      kinfo = CLIM_Ok
+c
+c*    1. check for this port in my list
+c     ---------------------------------
+c
+      irecv = 0
+      iport = -1
+c
+      IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
+      IF (iport.lt.0) THEN
+         kinfo = CLIM_BadPort
+         WRITE(nulprt,FMT='(A,A)')
+     *         'Import - WARNING - Invalid port out: ', 
+     $        cports(id_port_id)
+         GO TO 1010
+      ENDIF
+c
+c*    2. check for connected ports (in)
+c     ---------------------------------
+c
+      WRITE(nulprt,FMT='(A,A)') 'Import - ', cports(iport)
+c
+      ityp = myport(2,iport)
+      ibyt = myport(3,iport)
+c
+      DO 290 ip=1,myport(5,iport)
+c
+         ilk  = myport(5+ip,iport)
+         imod = mylink(1,ilk)
+         itid = mylink(2,ilk)
+         itag = mylink(3,ilk) - i4kstep / ig_frqmin
+         iseg = mylink(4,ilk)
+c
+c*   Implementation with "blocking" receives : the program will wait
+c*   indefinitely until a message is received (this may generate a
+c*   deadlock if all models are waiting on a receive).
+c*   However this method will be more efficient in most cases than the
+c*   receives with a time-out loop. 
+c
+#ifdef __DEBUG
+c
+c added to detect deadlocks (J. Latour, 2004-04-28)
+c
+         CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+         WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag,
+     *       ' comm = ',mpi_comm,' result is : ',iflag
+         CALL flush(nulprt) 
+
+         IF (.NOT.iflag) THEN
+             icount = 0
+             WAITLOOP:  DO
+             CALL  MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+             icount = icount + 1
+             IF ( iflag ) EXIT WAITLOOP
+             IF ( icount .GE. icountmax ) THEN
+                 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag,
+     *               ' still negative after ',icountmax,' seconds : Abort the job'
+                 CALL flush(nulprt)
+                 CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+             ENDIF
+             call sleep(1)
+             END DO WAITLOOP
+             WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
+             call flush(nulprt)
+         ENDIF
+#endif
+            CALL MPI_Recv ( pkwork, ig_maxtype, MPI_PACKED, itid,
+     *                       itag, mpi_comm, istatus, info ) 
+            CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, info )
+c
+            IF ( info .EQ. CLIM_ok  .AND.  imaxbyt .GT. 0) THEN
+               ilgb = 0
+               iposbuf = 0
+               DO 260 is=1,iseg
+                  ioff = mylink(4+2*is-1,ilk) * ibyt + 1
+                  ilen = mylink(4+2*is,ilk)
+c
+c                 IF     ( ityp .EQ. CLIM_Integer ) THEN
+c                     CALL MPI_Unpack ( pkwork, ig_maxtype, iposbuf, 
+c     *                 pfield(ioff), ilen, MPI_INTEGER, mpi_comm,info)
+c                 ELSEIF ( ityp .EQ. CLIM_Real ) THEN
+                  IF ( ityp .EQ. CLIM_Real ) THEN
+C                     IF ( kind(rl_testvar) .eq. 4 ) THEN
+                     IF ( ip_realwp_p .eq. ip_single_p ) THEN
+                         CALL MPI_Unpack ( pkwork, ig_maxtype, iposbuf,
+     *                       pfield(ioff), ilen, MPI_REAL, 
+     *                       mpi_comm, info)
+C                     ELSE IF ( kind(rl_testvar) .eq. 8 ) THEN
+                     ELSE IF ( ip_realwp_p .eq. ip_double_p ) THEN
+                         CALL MPI_Unpack ( pkwork, ig_maxtype, iposbuf,
+     *                       pfield(ioff), ilen, MPI_DOUBLE_PRECISION, 
+     *                       mpi_comm, info)
+                     ENDIF
+c                 ELSEIF ( ityp .EQ. CLIM_Double ) THEN
+c                     CALL MPI_Unpack ( pkwork, ig_maxtype, iposbuf,
+c     *                  pfield(ioff), 
+c     *                  ilen, MPI_DOUBLE_PRECISION, mpi_comm, info)
+                 ELSE
+                     WRITE(nulprt,*)'Import - pb type incorrect ',ityp
+                     kinfo = CLIM_BadType
+                     GO TO 1010
+                 ENDIF
+                 ilgb = ilgb + ilen
+ 260           CONTINUE
+               IF (ilgb*ibyt .le. imaxbyt) THEN
+                   irecv  = irecv + 1
+                   nbrecv = nbrecv + ilgb * ibyt
+                   WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)')
+     *                 'Import - <from:',imod,
+     *                 '> <step:',kstep,
+     *                 '> <len:',ilgb,
+     *                 '> <type:',ibyt,
+     *                 '> <tag:',itag,'>'
+               ELSE
+                   kinfo = CLIM_Unpack
+                   WRITE(nulprt,FMT='(A,I3,A)')
+     *                 'Import - pb unpack <mpi ',info,'>'
+               ENDIF
+           ELSE
+               kinfo = CLIM_TimeOut
+               WRITE(nulprt,FMT='(A,I3,A)')
+     *              'Import - abnormal exit from trecv <mpi ',info,'>'
+           ENDIF
+c
+ 290  CONTINUE
+c
+      WRITE(nulprt,FMT='(A,I3,A)')
+     *     'Import - ',irecv,' fields imported'
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CALL FLUSH(nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Init_Oasis.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Init_Oasis.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Init_Oasis.F	(revision 1677)
@@ -0,0 +1,910 @@
+       SUBROUTINE CLIM_Init_Oasis(cdexp,cdnam,knmods,
+     &                     cdmodnam, kbcplproc, kbtotproc,cdmpiarg, 
+     &                     ida_unitmod, ktrout,kinfo)
+c
+c*    *** Init ***   CLIM 3.0
+c
+c     purpose:
+c     --------
+c        start models
+c
+c     interface:
+c     ----------
+c        cdexp  : experience descriptor
+c        cdnam  : name of the calling model
+c	 knmods	: number of models to be launched
+c        cdmodnam : names of models to be launched 
+c        kbcplproc : number of processes implied in the coupling
+c                    for each model to be launched
+c        kbtotproc : total number of procs for each model to be launched
+c        cdmpiarg: nothing significant for MPI1 and launching argument 
+c                  for each model to be launched for MPI2
+c        ida_unitmod: minimum logfile unit number for each model
+c        ktrout : unit number for trace file
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-1 (or mpi-2)
+c
+c     author:
+c     -------
+c       Sophie Valcke  - CERFACS (08/09/00 -created from CLIM_Init)
+c       Jean Latour - F.S.E. - Version MPMD start with mpi-1
+c                   - implies the use of mpiexec server process on VPPs
+c                     or the command mpirun on most platfomrs
+c       Arnaud Caubel - FECIT (08/02) - removed some arguments and added 
+c                                       dynamic allocation
+c
+c     ----------------------------------------------------------------
+c
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+      USE mod_parameter
+      USE mod_timestep
+      USE mod_string
+      USE mod_unitncdf
+      USE mod_hardware
+      USE mod_calendar
+cvg>>
+      USE mod_label
+cvg<<
+      IMPLICIT NONE
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      CHARACTER*(*) cdexp, cdnam
+      INTEGER (kind=ip_intwp_p)	    knmods, ktrout,kinfo
+      CHARACTER*6   cdmodnam(knmods)
+      INTEGER (kind=ip_intwp_p)     kbtotproc(knmods), 
+     $    kbcplproc(knmods), ida_unitmod(knmods)
+      CHARACTER*80  cdmpiarg(knmods)
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)     iost, ip, iprcou, imodst, iprmod
+      INTEGER (kind=ip_intwp_p)     imyrank, inumproc, mynummod
+      INTEGER (kind=ip_intwp_p)     il_maxcplproc, iargs, il_mpisize, 
+     $    kcomm_local
+      INTEGER (kind=ip_intwp_p)      il_CLIM_Maxport, il_CLIM_MaxLink
+      INTEGER (kind=ip_intwp_p)     ji, jj, jl, jn, ibuff, il_err, ib
+      INTEGER (kind=ip_intwp_p)     icolor, icolorl, ikey, il_size, 
+     $    iposbuf, info
+      INTEGER (kind=ip_intwp_p)       impi_intercomp(knmods), 
+     $    impi_newcomm(knmods+1)
+      INTEGER (kind=ip_intwp_p)       iarrb(2)
+      INTEGER (kind=ip_intwp_p)     mpi_status(MPI_STATUS_SIZE)
+      INTEGER (kind=ip_intwp_p)     icolmods(knmods)
+      INTEGER (kind=ip_intwp_p), PARAMETER :: iargmax=20
+      INTEGER (kind=ip_intwp_p), PARAMETER :: itagcol=9876
+      REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE ::  rl_work
+      REAL (kind=ip_realwp_p) rl_testvar
+      CHARACTER*32  cdmodnam_aux(knmods)
+      CHARACTER*24  cdspawnarg(iargmax)
+      CHARACTER*(CLIM_Clength),DIMENSION(:), ALLOCATABLE :: cunames
+      INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iarr_err
+      INTEGER(kind=ip_intwp_p) :: integer_byte_size, ii, io_size, 
+     $    integer_io_size, il_ibyt, il_int, il_char, il_log, il_rl_work
+      LOGICAL :: ll_log
+      CHARACTER*1 :: cl_char 
+cvg>>
+      INTEGER (kind=ip_intwp_p)  grids_start, grids_done
+      INTEGER (kind=ip_intwp_p)  itype, ilen, itag 
+      INTEGER (kind=ip_intwp_p)  idproc
+      CHARACTER*8                cgrdnamnc 
+      LOGICAL                    existent
+cvg<<
+c     ----------------------------------------------------------------
+c
+c*    0. get arguments and some Initilizations
+c     ----------------------------------------
+c
+      kinfo  = CLIM_Ok
+      nexit = 0
+c
+      cgroup=' '
+      cgroup=cdexp
+      cmynam=' '
+      cmynam=cdnam
+      impi_intercomp(:)=0
+      impi_newcomm(:)=0
+      iarrb(:)=0
+      icolmods(:)=0
+      cdmodnam_aux(:)=' '
+      cdspawnarg(:)=' '
+      mpi_status(:)=0
+      rl_testvar=0.0_ip_realwp_p
+      ibuff=0_ip_intwp_p
+c
+      nports = 0
+      nlinks = 0
+      nbsend = 0
+      nbrecv = 0
+c
+c*    1. open trace file 
+c     ------------------
+c
+      iost = 0
+      nulprt = ktrout
+      WRITE (cnaprt,FMT='(A,''.prt'')') cdnam
+      OPEN (UNIT=nulprt, FILE=cnaprt, STATUS='UNKNOWN',
+     *      FORM='FORMATTED', ERR=110, IOSTAT=iost)
+c
+  110 CONTINUE
+      IF (iost.ne.0) THEN
+         WRITE(6,*) 'ABORT in Init_Oasis - unable to open trace file ', 
+     $        iost
+         WRITE(6,*) nulprt, ' ', cnaprt
+         CALL FLUSH(nulprt)
+         CALL ABORT
+      ENDIF
+c
+      WRITE (nulprt, FMT='(A)')  'Init_Oasis - CLIM/MPI'
+      WRITE (nulprt, FMT='(A,A)') 'Init_Oasis - experiment name: ', 
+     $    cgroup
+      WRITE (nulprt, FMT='(A,A)') 'Init_Oasis - name of the model: ',
+     $    cdnam
+c
+c*    2. Start global MPI environment for OASIS and models
+c     ----------------------------------------------------
+c
+      CALL MPI_INIT(mpi_err)
+      IF(mpi_err .NE. MPI_SUCCESS) GOTO 211
+      WRITE(UNIT = nulprt,FMT = *)' MPI_INIT done '
+c
+      CALL MPI_COMM_SIZE(MPI_COMM_WORLD,inumproc,mpi_err)
+      IF(mpi_err .NE. MPI_SUCCESS) GOTO 212
+      WRITE(UNIT = nulprt,FMT = *)' MPI_COMM_SIZE done ',inumproc
+c
+      CALL MPI_COMM_RANK(MPI_COMM_WORLD,imyrank,mpi_err)
+      IF(mpi_err .NE. MPI_SUCCESS) GOTO 213
+      WRITE(UNIT = nulprt,FMT = *)' MPI_COMM_RANK done ',imyrank
+c
+c
+c*    3. Test which MPI version we want to use
+c*    ----------------------------------------
+c
+#ifdef use_comm_MPI1
+c
+c*    MPI_COMM_WORLD is the global communicator for all processes
+c*    it includes Oasis and all model processes
+c
+         CALL MPI_COMM_DUP(MPI_COMM_WORLD,mpi_comm,mpi_err)
+         WRITE(nulprt,*)'Init_Oasis - - comm_dup done= ',mpi_comm
+c
+c*    3.1 If MPI1 context then split global communicator into disjoint 
+c*        communicators local for each model
+c     ----------------------------------------------------------------    
+c
+c*    3.1.1 generates a "color" from the model name (4 characters)
+c*    ----------------------------------------------------------
+c
+         ALLOCATE (cunames(inumproc), stat = il_err)
+         IF (il_err.NE.0) WRITE (nulprt,*) 'Init_Oasis - Error in 
+     $        "cunames" allocation '
+         cunames(:)=' '
+         call MPI_Allgather(cmynam,CLIM_Clength,MPI_CHARACTER,
+     &        cunames,CLIM_Clength,MPI_CHARACTER,
+     &        mpi_comm,mpi_err)
+         icolor=1
+         DO WHILE ((trim(cmynam).ne.trim(cunames(icolor))).and.
+     &        (icolor.le.inumproc))
+            icolor=icolor+1
+         END DO 
+         IF (icolor.le.inumproc) THEN 
+            WRITE(nulprt,*)'Init_OASIS - - table lookup:',
+     $           cunames(icolor)
+            icolor=icolor*100
+            WRITE(nulprt,*)'Init_OASIS - - color after table lookup:',
+     &           icolor
+         ELSE 
+            Write(nulprt,*) 'Init_OASIS - - Could not find myself in '
+            Write(nulprt,*) '               the model namespace!'
+            Write(nulprt,*) 'Init_OASIS - - Check namcouple and model'
+            Write(nulprt,*) '               name tags for consistency!'
+            call MPI_ABORT (mpi_comm, 0, mpi_err)
+         ENDIF
+
+c     
+c*       3.1.2 computes color of all models
+c        --------------------------------
+c     
+         DO ji=1,knmods
+            cdmodnam_aux(ji) = cdmodnam(ji)
+         END DO
+         DO jl = 1,knmods
+            icolorl=1
+            do while ((trim(cdmodnam_aux(jl)).ne.
+     $           trim(cunames(icolorl))).and.(icolorl.le.inumproc))
+               icolorl=icolorl+1
+            END DO
+            IF (icolorl.le.inumproc) THEN 
+               icolmods(jl)=100*icolorl
+               WRITE(nulprt,*) 'MPI color of model ',jl,' ',
+     *              cdmodnam_aux(jl),' is : ',icolmods(jl) 
+            ELSE 
+               Write(nulprt,*) 'Init_OASIS - - No match in the'
+               Write(nulprt,*) '               model namespace!'
+               Write(nulprt,*) 'Init_OASIS - - Check namcouple '
+               Write(nulprt,*) 'model name tags for consistency!'
+               call flush(nulprt)
+               call MPI_ABORT (mpi_comm, 0, mpi_err)
+            ENDIF 
+         END DO
+         DEALLOCATE (cunames)
+c     
+c*       3.1.3 split MPI_COMM_WORLD in local, disjoints, communicators
+c*       -----------------------------------------------------------
+c     
+         ikey = 1
+         call MPI_COMM_SPLIT(MPI_COMM_WORLD, icolor, ikey,
+     *        kcomm_local, mpi_err)
+         IF(mpi_err .NE. MPI_SUCCESS) GOTO 216
+c     
+c*       3.1.4 Send to each process (involved or not in coupling) its
+c*             model number "mynummod". This is obtained by comparing the
+c*             "color" of this process with the list of colors icolmods
+c        ----------------------------------------------------------------
+
+         DO jn = 1,inumproc-1
+            CALL MPI_Recv(ibuff,1,MPI_INTEGER,jn,itagcol,mpi_comm,
+     *           mpi_status, mpi_err)
+            mynummod = -1
+            DO jl = 1,knmods
+               IF ( ibuff .EQ. icolmods(jl) ) mynummod = jl 
+            ENDDO
+c     
+            IF ( mynummod .EQ. -1 ) GOTO 215
+c     
+            CALL MPI_Send(mynummod,1,MPI_INTEGER,jn,itagcol,mpi_comm,
+     *           mpi_err)
+         ENDDO
+         CALL MPI_COMM_SIZE(mpi_comm,il_mpisize,mpi_err)
+#else
+c
+c*    3.2 If MPI2 context then spawn models
+c*    --------------------------------------
+c 
+         CALL MPI_COMM_DUP(MPI_COMM_WORLD,impi_newcomm(1),mpi_err)
+         WRITE(nulprt,*)'Init - - comm_dup done= ',impi_newcomm(1)
+
+         DO jl=1,knmods
+c
+c       Parse optional arguments for the model
+c
+c*      print optional arguments cdmpiarg(jl)
+c
+            WRITE(nulprt,*)'Init_Oasis - - model number : ',jl
+            WRITE(nulprt,*)'Init_Oasis - - model name = ',cdmodnam(jl)
+            WRITE(nulprt,*)'Init_Oasis - - argument string = ',
+     $           cdmpiarg(jl)
+c
+            call CLIM_Parse(cdmpiarg(jl), cdspawnarg, iargs, iargmax)
+c
+            WRITE(nulprt,*)'Init_Oasis - - number of args = ',iargs
+c     
+c       Individual spawn of each model
+c 
+            ALLOCATE (iarr_err(kbtotproc(jl)), stat = il_err)
+            IF (il_err.NE.0) THEN
+                WRITE (nulprt,*) 'Error iarr_err allocation'
+                CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+
+            CALL MPI_COMM_SPAWN(cdmodnam(jl),cdspawnarg,
+     &           kbtotproc(jl), MPI_INFO_NULL, 0,
+     &           impi_newcomm(jl), impi_intercomp(jl), 
+     &           iarr_err, mpi_err)
+            DO ib = 1, kbtotproc(jl) 
+              IF(iarr_err(ib) .NE. MPI_SUCCESS) GOTO 214
+            END DO
+            DEALLOCATE(iarr_err)
+            IF(mpi_err .NE. MPI_SUCCESS) GOTO 214
+            WRITE(UNIT = nulprt,FMT = *)' MPI_COMM_SPAWN done '
+c     
+            CALL MPI_Intercomm_merge(impi_intercomp(jl), .false., 
+     &           impi_newcomm(jl+1), il_err)
+            CALL MPI_Comm_size(impi_newcomm(jl+1), mpi_size, mpi_err)
+            CALL MPI_Comm_rank(impi_newcomm(jl+1), mpi_rank, mpi_err)
+c     
+            WRITE(nulprt,*)'Init_Oasis - - oasis new size = ',mpi_size
+            WRITE(nulprt,*)'Init_Oasis - - oasis new rank = ',mpi_rank
+            iarrb(1) = jl+1
+            iarrb(2) = knmods
+            CALL MPI_BCAST(iarrb, 2, MPI_INTEGER, 0,
+     &           impi_newcomm(jl+1), mpi_err)
+c
+         ENDDO
+c
+         WRITE(nulprt,*)'Init_Oasis - - oasis all models started '
+         CALL MPI_COMM_DUP(impi_newcomm(knmods+1), mpi_comm, mpi_err)
+         DO jl=1,knmods+1
+            call MPI_COMM_FREE(impi_newcomm(jl), mpi_err)
+         ENDDO
+         CALL MPI_Comm_size(mpi_comm, il_mpisize, mpi_err)
+c
+
+#endif
+         
+C*    4.0 Initialize global variables, send information to 
+c         model processes and allocate arrays.
+c      --------------------------------------------------------
+
+      ig_clim_nfield = ig_total_nfield
+      integer_byte_size = BIT_SIZE(ii)/8
+      INQUIRE (iolength=io_size) ii
+      integer_io_size = io_size
+      il_int = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) rl_testvar
+      il_ibyt = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) cl_char
+      il_char = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) ll_log
+      il_log = io_size/integer_io_size*integer_byte_size
+      il_rl_work = (29 + 64*ig_clim_nfield) * (il_char/il_ibyt + 1) + 
+     $    (9 + 3*knmods + 9*ig_clim_nfield) * (il_int/il_ibyt + 1) +
+     $    3 * (il_log/il_ibyt + 1)
+      ALLOCATE (rl_work(il_rl_work), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "rl_work" 
+     $    allocation in CLIM_Init_Oasis routine ! '
+      rl_work(:)=0
+      il_size = il_rl_work * il_ibyt
+      il_CLIM_Maxport = 2 * ig_clim_nfield
+      ig_frqmin = ig_total_frqmin
+      ig_ntime = ntime
+c
+      DO jn = 1, il_mpisize-1
+        CALL MPI_Send(knmods, 1, MPI_INTEGER, jn, itagcol,
+     $      mpi_comm, mpi_err)
+        IF (mpi_ERR.ne.MPI_SUCCESS) THEN
+            WRITE(UNIT = nulprt,FMT = *)'Init_Oasis - Problem with 
+     $          sending of information to models !'
+            CALL HALTE ('STOP in CLIM_Init_Oasis')
+        ENDIF
+        CALL MPI_Send(ig_clim_nfield, 1, MPI_INTEGER, jn, itagcol+1,
+     $      mpi_comm, mpi_err)
+        IF (mpi_ERR.ne.MPI_SUCCESS) THEN
+            WRITE(UNIT = nulprt,FMT = *)'Init_Oasis - Problem with 
+     $          sending of information to models !'
+            CALL HALTE ('STOP in CLIM_Init_Oasis')
+        ENDIF
+      END DO
+      iposbuf = 0
+      call MPI_Pack (cgroup, 8, MPI_CHARACTER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (ntime, 1, MPI_INTEGER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (kbcplproc, knmods, MPI_INTEGER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (kbtotproc, knmods, MPI_INTEGER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (ida_unitmod, knmods, MPI_INTEGER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_frqmin, 1, MPI_INTEGER, rl_work, il_size,
+     $     iposbuf, mpi_comm, info)
+      call MPI_Pack (cg_input_field, 8*ig_clim_nfield, MPI_CHARACTER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (cg_output_field, 8*ig_clim_nfield, MPI_CHARACTER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_lag, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_reverse, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_invert, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_freq, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_total_nseqn, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (cg_restart_file, 8*ig_clim_nfield, MPI_CHARACTER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_no_rstfile, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_nbr_rstfile, 1, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (lncdfrst, 1, MPI_LOGICAL, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (lg_oasis_field, 1, MPI_LOGICAL, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_total_state, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (ig_local_trans, ig_clim_nfield, MPI_INTEGER, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (cg_input_file, 32*ig_clim_nfield, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (ig_date, 6, MPI_INTEGER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (ig_numlab, ig_clim_nfield, MPI_INTEGER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+CSV>>
+      call  MPI_Pack (cgrdnam, 5, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info) 
+      call  MPI_Pack (cglonsuf, 4, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (cglatsuf, 4, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (crnlonsuf, 4, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (crnlatsuf, 4, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (cga_locatorbf, 4*ig_clim_nfield, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call  MPI_Pack (cga_locatoraf, 4*ig_clim_nfield, MPI_CHARACTER,
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+      call MPI_Pack (lg_bsend, 1, MPI_LOGICAL, 
+     $     rl_work, il_size, iposbuf, mpi_comm, info)
+CSV<< 
+      DO jn = 1, il_mpisize-1
+        CALL MPI_Send(rl_work, iposbuf, MPI_PACKED, jn, itagcol+2,
+     $      mpi_comm, mpi_err)
+        IF (mpi_ERR.ne.MPI_SUCCESS) THEN
+            WRITE(UNIT = nulprt,FMT = *)'Init_Oasis - Problem with 
+     $          sending of information to models !'
+            CALL HALTE ('STOP in CLIM_Init_Oasis')
+        ENDIF
+      END DO
+      il_maxcplproc = 1
+      DO ji = 1, knmods
+        IF (il_maxcplproc.lt.kbcplproc(ji)) 
+     $      il_maxcplproc = kbcplproc(ji)
+      END DO
+
+      DEALLOCATE(rl_work)
+c      
+C*    4.1 Define ncplprocs, the total number of processes involved
+C*    in the coupling, including Oasis and initialize il_CLIM_MaxLink
+C     ------------------------------------------------------------
+c
+      ncplprocs=1
+      DO 3 ji = 1, knmods
+        ncplprocs = ncplprocs + kbcplproc(ji)
+ 3    CONTINUE
+c
+      il_CLIM_MaxLink = ncplprocs * il_CLIM_Maxport
+
+C     4.2 Allocate and initialize arrays defined in comclim MODULE 
+c     ------------------------------------------------------------
+c
+      ALLOCATE (modtid(0:ncplprocs-1), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "modtid" allocation in 
+     $    CLIM_Init_Oasis routine ! '
+      modtid(:)=0
+       ALLOCATE (ncode(0:ncplprocs-1), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "ncode" allocation in 
+     $    CLIM_Init_Oasis routine ! '
+      ncode(:)=0
+       ALLOCATE (delta(0:ncplprocs-1), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "delta" allocation in 
+     $    CLIM_Init_Oasis routine ! '
+      delta(:)=0
+       ALLOCATE (delte(0:ncplprocs-1), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "delte" allocation in 
+     $    CLIM_Init_Oasis routine ! '
+      delte(:)=0
+       ALLOCATE (cnames(0:ncplprocs-1), stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "cnames" allocation in 
+     $    CLIM_Init_Oasis routine ! '
+      cnames(:)=' '
+c
+      ALLOCATE (myport(5+il_maxcplproc,il_CLIM_Maxport), 
+     $    stat = il_ERR)
+      IF (il_ERR.ne.CLIM_Ok) WRITE(UNIT = nulprt,FMT = *)' Problem 
+     $    in myport allocation in CLIM_Init_Oasis !'
+      myport(:,:)=0
+      ALLOCATE (mydist(CLIM_ParSize, il_CLIM_Maxport), 
+     $    stat = il_ERR)
+      IF (il_ERR.ne.CLIM_Ok) WRITE(UNIT = nulprt,FMT = *)' Problem 
+     $    in mydist allocation in CLIM_Init_Oasis !'
+      mydist(:,:)=0
+      ALLOCATE (cports(il_CLIM_Maxport), stat = il_ERR)
+      IF (il_ERR.ne.CLIM_Ok) WRITE(UNIT = nulprt,FMT = *)' Problem 
+     $    in mydist allocation in CLIM_Init_Oasis !'
+      cports(:)=' '
+      ALLOCATE(clrport(il_CLIM_Maxport), stat = il_ERR)
+      IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)'Error in clrport 
+     $    allocation in CLIM_Init_Oasis !'
+      clrport(:)=' '
+      ALLOCATE(irdist(CLIM_ParSize, il_CLIM_Maxport), stat = il_ERR)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in irdist allocation 
+     $    in CLIM_Init_Oasis'
+      irdist(:,:)=0
+      ALLOCATE(irport(5,il_CLIM_Maxport ), stat = il_ERR)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in irport allocation 
+     $    in CLIM_Init_Oasis'
+      irport(:,:)=0
+      ALLOCATE (mylink(4+CLIM_ParSize,il_CLIM_MaxLink), stat = il_ERR)
+      IF (il_ERR.ne.CLIM_Ok) WRITE(UNIT = nulprt,FMT = *)' Problem 
+     $    in mylink allocation in CLIM_Init_Oasis !'
+      mylink(:,:)=0
+      DO 10 ip = 0, ncplprocs-1
+        modtid(ip) = -1
+        cnames(ip) = ' '
+ 10   CONTINUE
+
+c
+C*    4.3 Define modtid, the vector giving, for each process involved
+C*        in the coupling,  its number in mpi_comm (i.e in all model 
+C*        processes involved OR NOT in the coupling) 
+C         -----------------------------------------------------------
+c
+c     For coupler
+      iprcou = 0
+      imodst = 0
+      modtid(0) = 0
+c     For models
+      DO 5 ji = 1, knmods
+        IF (ji .eq. 1) THEN
+           imodst = 1
+        ELSE
+           imodst = imodst + kbtotproc(ji-1)
+        ENDIF
+        iprmod = 0
+        DO 7 jj = 1, kbcplproc(ji)
+          iprcou = iprcou + 1
+          iprmod = iprmod + 1
+          modtid(iprcou) = imodst + iprmod - 1
+ 7      CONTINUE
+ 5    CONTINUE
+
+C*    4.4 Define mynum, the number of the actual processor 
+c         in all processors involved in the coupling 
+C         -------------------------------------------------
+c
+c*    For the coupler (if mono-processor)
+      mynummod = 0
+      mynum = 0
+      nexit = 1
+c
+      WRITE(nulprt,*)'Init_Oasis - - Oasis mynummod = ', mynummod
+      WRITE(nulprt,*)'Init_Oasis - - Oasis mynum = ', mynum
+      WRITE(nulprt,*)'Init_Oasis - - modtid() = ', modtid
+
+cvg>>
+C*    4.5 Initialize writing of the grids file by the models
+C         --------------------------------------------------
+c
+      grids_start=0
+      WRITE(nulprt,*)'Init_Oasis - - check grids file:'
+      INQUIRE(FILE = cgrdnam, EXIST = existent)
+      IF (.NOT. existent) THEN
+         cgrdnamnc=cgrdnam//'.nc'
+         INQUIRE(FILE = cgrdnamnc, EXIST = existent)
+         IF (.NOT. existent) THEN
+            grids_start=1
+            WRITE(nulprt,*)
+     $           '             - no grids file found'
+            lncdfgrd = .true.
+         ELSE
+            WRITE(nulprt,*)
+     $           'Init_Oasis - - grids file "', cgrdnamnc, '" found'
+            lncdfgrd = .true.
+         ENDIF
+      ELSE
+         WRITE(nulprt,*)
+     $        'Init_Oasis - - grids file "', cgrdnam, '" found'
+            lncdfgrd = .false.
+      ENDIF
+      
+      idproc = 1
+      DO jl = 1, knmods
+c
+c*    Send starting flag (grids_start) to all model processors
+c
+         DO ip = idproc, idproc + kbtotproc(jl) - 1
+            WRITE(nulprt,FMT='(A)')'Send - grids_start'
+            ilen = 1
+            itype = MPI_INTEGER
+            itag = itagcol+3
+            CALL MPI_Send(grids_start, ilen, itype, ip, itag,
+     $           mpi_comm, MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,I1)')
+     $              'Send - <dest:',ip,'> <comm:',mpi_comm,'> <len:',
+     $              ilen,'> <type:',itype,'> <tag:',itag,'> ::  ',
+     $              grids_start
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)'Init_Oasis - - Problem sending
+     $              flag to initialize grids writing !'
+               WRITE(nulprt,*)'MPI_ERR: ', MPI_ERR
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+         ENDDO
+
+         IF (.NOT. existent) THEN
+c
+c*          Send grid file names and suffixes (mod_label) to master
+c*          proc of each model
+c
+c*          grids file name
+c 
+            WRITE(nulprt,FMT='(A)')'Send - cgrdnam'
+            ilen = 5
+            itype = MPI_CHARACTER
+            itag = itagcol+4
+            CALL MPI_Send(cgrdnam, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',itag,
+     $              '> ::  ', cgrdnam
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*) 
+     $              'Init_Oasis - - Problem sending grids file name !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c     
+c*          masks file name
+c
+            WRITE(nulprt,FMT='(A)')'Send - cmsknam'
+            ilen = 5
+            itype = MPI_CHARACTER
+            itag = itagcol+5
+            CALL MPI_Send(cmsknam, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',itag,
+     $              '> ::  ', cmsknam
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*) 
+     $              'Init_Oasis - - Problem sending masks file name !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          areas file name
+c
+            WRITE(nulprt,FMT='(A)')'Send - csurnam'
+            ilen = 5
+            itype = MPI_CHARACTER
+            itag = itagcol+6
+            CALL MPI_Send(csurnam, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',itag,
+     $              '> ::  ', csurnam
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*) 
+     $              'Init_Oasis - - Problem sending areas file name !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          longitudes suffix
+c
+            WRITE(nulprt,FMT='(A)')'Send - cglonsuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+7
+            CALL MPI_Send(cglonsuf, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',itag,
+     $              '> ::  ', cglonsuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)
+     $          'Init_Oasis - - Problem sending suffix for longitudes !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          latitudes suffix
+c
+            WRITE(nulprt,FMT='(A)')'Send - cglatsuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+8
+            CALL MPI_Send(cglatsuf, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',
+     $              itag,'> ::  ', cglatsuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)
+     $           'Init_Oasis - - Problem sending suffix for latitudes !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          corner longitudes suffix
+c
+            WRITE(nulprt,FMT='(A)')'Send - crnlonsuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+9
+            CALL MPI_Send(crnlonsuf, ilen, itype, idproc, itag,mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',
+     $              itag,'> ::  ', crnlonsuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)'Init_Oasis - - '
+               WRITE(nulprt,*)
+     $              '    Problem sending suffix for corner longitudes !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          corner latitudes suffix
+c
+            WRITE(nulprt,FMT='(A)')'Send - crnlatsuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+10
+            CALL MPI_Send(crnlatsuf, ilen, itype, idproc, itag,mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',
+     $              itag,'> ::  ', crnlatsuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)'Init_Oasis - - '
+               WRITE(nulprt,*)
+     $              '    Problem sending suffix for corner latitudes !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          masks suffix
+c
+            WRITE(nulprt,FMT='(A)')'Send - cmsksuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+11
+            CALL MPI_Send(cmsksuf, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',mpi_comm,
+     $              '> <len:', ilen,'> <type:',itype,'> <tag:',itag,
+     $              '> ::  ', cmsksuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)
+     $              'Init_Oasis - - Problem sending suffix for masks !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          areas suffix
+c     
+            WRITE(nulprt,FMT='(A)')'Send - csursuf'
+            ilen = 4
+            itype = MPI_CHARACTER
+            itag = itagcol+12
+            CALL MPI_Send(csursuf, ilen, itype, idproc, itag, mpi_comm,
+     $                    MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)')
+     $              'Send - <dest:',idproc,'> <comm:',
+     $              mpi_comm,'> <len:', ilen,'> <type:',itype,
+     $              '> <tag:',itag,'> ::  ', csursuf
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)
+     $              'Init_Oasis - - Problem sending suffix for areas !'
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+c
+c*          Wait until writing is finished
+c
+            grids_done=0
+            WRITE(nulprt,FMT='(A)')'Recv - grids_done'
+            ilen = 1
+            itype = MPI_INTEGER
+            itag = itagcol+13
+            CALL MPI_Recv(grids_done, ilen, itype, idproc, itag,
+     $           mpi_comm, mpi_status, MPI_ERR)
+            IF (MPI_ERR .EQ. MPI_SUCCESS) THEN
+               WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,I1)')
+     $              'Recv - <from:',idproc,'> <comm:',
+     $              mpi_comm,'> <len:', ilen,'> <type:',itype,
+     $              '> <tag:',itag,'> ::  ', grids_done
+               CALL FLUSH(nulprt)
+            ELSE
+               WRITE(nulprt,*)'Init_Oasis - - Problem receiving
+     $              flag that grids file is written!'
+               WRITE(nulprt,*)'MPI_ERR: ', MPI_ERR
+               CALL HALTE ('STOP in CLIM_Init_Oasis')
+            ENDIF
+         ENDIF
+         idproc = idproc + kbtotproc(jl)
+      ENDDO
+cvg<<
+
+c 
+C*    5. Normal EXIT
+C     --------------
+C
+ 1010 CONTINUE
+      WRITE (nulprt,FMT='(A)') 'Init_Oasis - -'
+      CALL FLUSH(nulprt)
+      RETURN
+C
+C*    6. Error : stop
+C     ---------------
+
+ 211  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Problem when starting MPI_Init_Oasis !!! ',
+     $    ' Mpi error code = ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' We STOP!!! Check the job parameters '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')
+ 212  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Problem with MPI_Comm_Size function !!! ',
+     $    ' Mpi error code = ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Number of processors = ',inumproc
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' We STOP!!! Check the job parameters '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')
+ 213  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Problem with MPI_Comm_Rank function !!! ',
+     $    ' Mpi error code = ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Rank of processor is : ',imyrank
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' We STOP!!! Check the job parameters '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')
+  214  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' The spawn of the models has a problem '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' In spawn mpi_err ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' We STOP!!! Check the job parameters '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')     
+ 215  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' The color of one process is incorrect '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' proc number =  ',jn, ' color = ',ibuff
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' We STOP!!! Check the job parameters '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')                 
+ 216  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Problem with MPI_Comm_Split function !!! ',
+     $    ' Mpi error code = ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      CALL HALTE ('STOP in CLIM_Init_Oasis')      
+c
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Parse.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Parse.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Parse.F	(revision 1677)
@@ -0,0 +1,154 @@
+      SUBROUTINE CLIM_Parse (cdarg, cdspawn, kargs, karmax)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL T *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *parse*  - Parsing routine
+C
+C     Purpose:
+C     -------
+C     parse string cdstr into cdspawn. Blanks are the separators between args.
+C     Each argument is defined as a continuous set of non-blanks characters
+C     the first argument is put into cdspawn(1), the second in cdspawn(2) ...
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *CLIM_Parse (cdarg, cdspawn, kargs, karmax)*
+C
+C     Input:
+C     -----
+C                cdarg   : line to be parsed (char string, including blanks)
+C                karmax  : maximum number of arguments to be found (parameter)
+C
+C     Output:
+C     ------
+C                cdspawn : extracted character strings (possibly blank string)
+C                karg    : number of arguments found (possibly 0)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference: 
+C     --------- 
+C     See OASIS manual (2000) 
+C 
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       J. Latour     00/09/15   created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      CHARACTER*80 cdarg
+      INTEGER (kind=ip_intwp_p)      kargs, karmax
+      CHARACTER*24 cdspawn(karmax)
+C
+C* ---------------------------- Local declarations -------------------
+C
+      CHARACTER*1  cdstr
+      DIMENSION    cdstr(80)
+      LOGICAL lnewarg
+      INTEGER (kind=ip_intwp_p), PARAMETER :: maxchar=80 
+      INTEGER (kind=ip_intwp_p), PARAMETER :: maxarg=24
+      INTEGER (kind=ip_intwp_p) ii, ji, nulin
+C
+C* - Parameter declarations MUST match dimension declarations of cdstr
+C* - and cdspawn
+C
+      CHARACTER (len=1), PARAMETER :: clblank = ' '
+      CHARACTER (len=1), PARAMETER :: clcmt = '#'
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialize arrays
+C        -----------------
+C
+C* - Transfer cdarg into cdstr
+C
+      DO 100 ji = 1,80
+        cdstr(ji) = cdarg(ji:ji)
+  100 CONTINUE
+C
+C* - Skip line if it is a comment
+C     
+      nulin=99
+ 110  IF (cdstr(1) .NE. clcmt) GO TO 130
+      READ (UNIT = nulin, FMT = 1001) cdarg
+      DO 120 ji = 1, 80
+         cdstr(ji) = cdarg(ji:ji)
+ 120  CONTINUE
+      GO TO 110
+ 130  CONTINUE 
+ 1001 FORMAT(A80)
+C     
+C* - Fill cdspawn with blanks and kargs with 0
+C
+      DO 210 ji = 1, karmax
+        cdspawn(ji) = clblank
+  210 CONTINUE 
+
+      kargs = 0
+      lnewarg = .TRUE.
+C
+C* - 2. Do the extraction work
+C       ----------------------
+C* - Check every character in cdstr, and fill cdspawn with contiguous
+C* - strings of nonblank characters : the arguments.
+C     
+      DO 220 ji = 1, maxchar 
+         IF ( cdstr(ji) .NE. clblank ) THEN
+            IF ( lnewarg ) THEN
+               kargs = kargs + 1 
+               IF ( kargs .GT. karmax ) THEN
+                  WRITE (UNIT = nulprt,FMT = *)
+     $            ' Too many arguments in list passed to model'
+                  WRITE (UNIT = nulprt,FMT = *)
+     $            ' We STOP!!! Check the file namcouple'
+                  CALL flush(nulprt)
+                  CALL halte('STOP in CLIM_Parse.f')
+               ENDIF
+               ii = 1 
+               cdspawn(kargs)(ii:ii) = cdstr(ji)
+               lnewarg = .FALSE.
+            ELSE
+               ii = ii+1
+               IF ( ii .GT. maxarg ) THEN
+                  WRITE (UNIT = nulprt,FMT = *)
+     $            ' Too many characters in argument passed to model'
+                  WRITE (UNIT = nulprt,FMT = *)
+     $            ' We STOP!!! Check the file namcouple'
+                  CALL flush(nulprt)
+                  CALL halte('STOP in CLIM_Parse.f')
+               ENDIF
+               cdspawn(kargs)(ii:ii) = cdstr(ji) 
+            ENDIF
+         ELSE
+            lnewarg = .TRUE.
+         ENDIF
+  220 CONTINUE
+C
+C*    3. End of routine
+C        --------------
+C
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Quit.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Quit.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Quit.F	(revision 1677)
@@ -0,0 +1,112 @@
+      SUBROUTINE CLIM_Quit(kinfo)
+c
+c*    *** Quit ***   CLIM 3.0
+c
+c     purpose:
+c     --------
+c        leave mpi
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-2
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c        Arnaud Caubel - Fecit - Added deallocation of CLIM arrays
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)	kinfo
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) info, il_rank, ji
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       il_bufsizebyt
+      REAL (kind=ip_double_p)  dl_bufaddr
+c
+c*    0. First Check
+c     --------------
+c
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Quit - should not be called'
+          GO TO 1010
+      ENDIF
+      WRITE(nulprt,*)'entering clim_quit'
+      kinfo = CLIM_Ok
+c
+      CALL MPI_Comm_Rank(mpi_comm,il_rank,mpi_err)
+c
+      DO ji = 0, ncplprocs-1 
+        IF (il_rank.eq.modtid(ji)) THEN
+            DEALLOCATE (ncode, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "ncode" 
+     $          deallocation in CLIM_Quit routine ! '
+            DEALLOCATE (delta, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "delta" 
+     $          deallocation in CLIM_Quit routine ! '
+            DEALLOCATE (delte, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "delte" 
+     $          deallocation in CLIM_Quit routine ! '
+            DEALLOCATE (cnames, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "cnames" 
+     $          deallocation in CLIM_Quit routine ! '
+            DEALLOCATE (myport, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $          in "myport" deallocation in CLIM_Quit !'
+            DEALLOCATE (mydist,stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $          in "mydist" deallocation in CLIM_Quit !'
+            DEALLOCATE (cports, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $          in "cports" allocation in CLIM_Quit !'
+            DEALLOCATE(clrport, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)'Error in clrport 
+     $          deallocation in CLIM_Quit !'
+            DEALLOCATE(irdist, stat = il_ERR)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "irdist" 
+     $          deallocation in CLIM_Quit'
+            DEALLOCATE(irport, stat = il_ERR)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "irport" 
+     $          deallocation in CLIM_Quit'
+            DEALLOCATE (mylink, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $          in "mylink" allocation in CLIM_Quit !'
+            DEALLOCATE (pkwork, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $          in "pkwork" allocation in CLIM_Quit !'
+            IF (lg_bsend) then
+               CALL MPI_Buffer_Detach(dl_bufaddr,il_bufsizebyt,mpi_err)
+               DEALLOCATE (dg_bufsend, stat = il_ERR)
+               IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)' Problem 
+     $             in "dg_bufsend" allocation in CLIM_Quit !'
+            ENDIF
+        ENDIF
+      END DO
+      DEALLOCATE (modtid, stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)'Error in "modtid" 
+     $    deallocation in CLIM_Quit routine ! '
+c
+c
+      CALL MPI_Finalize ( info )
+c
+      WRITE(nulprt,FMT='(A,I3,A)')
+     *     'Quit - exit status <mpi ',info,'>'
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CLOSE (nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start.F	(revision 1677)
@@ -0,0 +1,66 @@
+      SUBROUTINE CLIM_Start(kinfo)
+c
+c*    *** Start ***   CLIM 3.0
+c
+c     purpose:
+c     --------
+c        beginning of the coupled run
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-2
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c        Arnaud Caubel  - FECIT - removed kmxtag as argument
+c
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) kinfo
+c     ----------------------------------------------------------------
+c
+c*    0. First Check
+c     --------------
+c
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Start - should not be called'
+          GO TO 1010
+      ENDIF
+      kinfo  = CLIM_Ok
+      nexit  = 0
+c
+      CALL CLIM_Start_MPI(kinfo)
+c
+c*    4. Get wall clock differences with other models
+c     -----------------------------------------------
+c
+c       4.1 Initilizations
+c       ------------------
+c
+      delta(0:ncplprocs-1)=0.
+      delte(0:ncplprocs-1)=0.
+c
+c*    correct execution
+c
+      nexit = 1
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      WRITE (nulprt,FMT='(A)') 'Returning from Start -- '
+      CALL FLUSH(nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start_MPI.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start_MPI.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Start_MPI.F	(revision 1677)
@@ -0,0 +1,323 @@
+      SUBROUTINE CLIM_Start_MPI(kinfo)
+c
+c*    *** Start-mpi ***   CLIM 3.0
+c
+c     purpose:
+c     --------
+c        beginning of the coupled run (MPI-2 only)
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     method:
+c     -------
+c        With MPI2, use the new intra-communicator created by the
+c                   MPI_Intercomm_merge in CLIM_Init (models)
+c                   or in inicmc via CLIM_Init (coupler Oasis)
+c
+c     lib mp:
+c     -------
+c        mpi-1 (or mpi-2)
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c        Sophie Valcke  - CERFACS (08/09/00 -modified)
+c        Arnaud Caubel  - FECIT (08/02 - removed kmxtag as argument)
+c
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim 
+      USE mod_comclim
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) kinfo
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)    ip, info1, info, ilgdt, ipos, is,
+     $    itag1, isdmod, incp, ipotag,nsegid
+      INTEGER (kind=ip_intwp_p)    irempo, il_maxtag
+c
+      INTEGER (kind=ip_intwp_p), PARAMETER ::    ibuflen=3
+      INTEGER (kind=ip_intwp_p)    iposbuf, ibuff_mpi(ibuflen) 
+      INTEGER (kind=ip_intwp_p)    istatus(MPI_STATUS_SIZE), imaxbyt
+      REAL (kind=ip_realwp_p) rl_testvar
+      LOGICAL      ll_flag
+      INTEGER (kind=ip_intwp_p), allocatable :: ireq(:)
+      INTEGER (kind=ip_intwp_p)              :: ireqrecv
+      INTEGER (kind=ip_intwp_p)              :: irc
+      INTEGER (kind=ip_intwp_p)              :: rpkwork(ig_CLIMmax)
+c     ----------------------------------------------------------------
+c
+c
+c     0. define some variables 
+c     ------------------------
+c
+      WRITE(nulprt,*)'Start - -  '
+c           
+      nexit  = 0
+      istatus(:)=0
+      ibuff_mpi(:)=0
+      rl_testvar=0.0_ip_realwp_p
+c
+      call MPI_Attr_get(MPI_COMM_WORLD, MPI_TAG_UB, CLIM_MaxTag, 
+     $    ll_flag,info)
+      if(info.ne.MPI_SUCCESS) then
+        write(nulprt, * )'CLIM_Start_MPI -- MPI_Attr_get failed !',info
+        call MPI_ABORT (mpi_comm, 0, info)
+      endif
+      if ( .not. ll_flag ) then
+         write(nulprt, * ) 'Warning:  MPI_Attr_get did not return '
+         write(nulprt, * ) ' a valid CLIM_MaxTag!'
+         write(nulprt, * ) ' CLIM_MaxTag is set to 32767!'
+         CLIM_MaxTag = 32767
+      else
+         write(nulprt, * ) 'CLIM_MaxTag is now ', CLIM_MaxTag
+!
+!     limit CLIM_MaxTag to 2^^30 - 1 (J. Latour)
+!
+         if ( CLIM_MaxTag .gt. 1073741823 ) CLIM_MaxTag =  1073741823
+         write(nulprt, * ) 'CLIM_MaxTag is now ', CLIM_MaxTag
+!
+      endif
+      il_maxtag = CLIM_MaxTag - 1
+      itag1 = CLIM_MaxTag
+      ilgdt = CLIM_ParSize
+C
+      ig_maxtype = ig_CLIMmax*kind(rl_testvar)
+C
+c*    1. broadcast usefull informations
+c     ---------------------------------
+c
+      ibuff_mpi(1) = mynum 
+      ibuff_mpi(2) = modtid(mynum) 
+      ibuff_mpi(3) = nports
+c
+      WRITE(nulprt,FMT='(A,A)') 'Start- send- MODEL ',cmynam
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  num  :',mynum
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  tid  :',modtid(mynum)
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  nport:',nports
+c
+      iposbuf = 0
+      call MPI_Pack ( ibuff_mpi, ibuflen, MPI_INTEGER, pkwork,
+     *                ig_maxtype, iposbuf, mpi_comm, info )
+      call MPI_Pack ( cmynam, CLIM_Clength, MPI_CHARACTER, pkwork,
+     *                ig_maxtype, iposbuf, mpi_comm, info )
+      DO 210 ji=1,nports
+         call MPI_Pack ( cports(ji), CLIM_Clength, MPI_CHARACTER,
+     *           pkwork, ig_maxtype, iposbuf, mpi_comm, info )
+         call MPI_Pack ( myport(1,ji), 5, MPI_INTEGER, pkwork,
+     *                   ig_maxtype, iposbuf, mpi_comm, info )
+         call MPI_Pack ( mydist(1,ji), ilgdt, MPI_INTEGER, pkwork,
+     *                   ig_maxtype, iposbuf, mpi_comm, info )
+ 210   CONTINUE 
+c
+       ALLOCATE(ireq(0:ncplprocs))
+       irc = 0
+c
+      DO 220 ji = 0 , ncplprocs-1
+c
+c       Send to all processors involved in the coupling except itself
+c*      This MPI_Send may cause deadlocks, IF your mailbox size is not 
+c*      large enough; in that case the size of the mailbox should be 
+c*      increased.
+        IF ( ji .NE. mynum ) THEN
+            CALL MPI_Isend ( pkwork, iposbuf, MPI_PACKED, modtid(ji),
+     *                      itag1, mpi_comm, ireq(irc), info )
+          irc = irc+1
+c
+        ENDIF 
+ 220  CONTINUE
+
+      WRITE (nulprt,FMT='(A,I3,A,I8,A)') 
+     * 'Start - broadcast from mynum = ',mynum,' <MPI ',info,'>'
+c
+c*    3. get these infos from other models and check ports
+c     ----------------------------------------------------
+c
+      imaxbyt=0
+      ireqrecv=0
+      DO 380 ip=1,ncplprocs-1
+c
+c Blocking receive (to comment if use of non-blocking receive)
+        CALL MPI_Irecv(rpkwork, ig_maxtype, MPI_PACKED, MPI_ANY_SOURCE,
+     *                 itag1, mpi_comm, ireqrecv, info1 )
+        CALL MPI_Wait ( ireqrecv, istatus, info )
+        CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, info )
+        IF ( info .NE. 0 ) THEN
+            kinfo = CLIM_Unpack
+            WRITE(nulprt,FMT='(A,I3,A)')
+     *                 'Import - pb unpack <mpi ',info,'>'
+            GO TO 1010
+        ENDIF
+c END of blocking receive
+c
+c       
+        iposbuf = 0
+        CALL MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, ibuff_mpi,
+     *                      ibuflen, MPI_INTEGER, mpi_comm, info )
+        IF ( info .NE. 0 ) THEN
+            kinfo = CLIM_Unpack
+            WRITE(nulprt,FMT='(A,I3,A)')
+     *                 'Import - pb unpack <mpi ',info,'>'
+            GO TO 1010
+        ENDIF
+c
+        isdmod         = ibuff_mpi(1)
+        modtid(isdmod) = ibuff_mpi(2)
+        irempo         = ibuff_mpi(3)
+c
+        call MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, cnames(isdmod),
+     *                   CLIM_Clength, MPI_CHARACTER, mpi_comm, info )
+        DO 310 ji=1,irempo
+          call MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, clrport(ji),
+     *                   CLIM_Clength, MPI_CHARACTER, mpi_comm, info )
+          call MPI_Unpack( rpkwork, ig_maxtype, iposbuf, irport(1,ji), 
+     *                           5, MPI_INTEGER, mpi_comm, info )
+          call MPI_Unpack( rpkwork, ig_maxtype, iposbuf, irdist(1,ji),
+     *                           ilgdt, MPI_INTEGER, mpi_comm, info )
+ 310    CONTINUE
+c
+        WRITE (nulprt,FMT='(A,A)')  'Start - MODEL ',cnames(isdmod)
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   num  :',isdmod
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   tid  :',modtid(isdmod)
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   nport:',irempo
+c
+        ncode(isdmod) = 0
+c
+        DO 350 ji=1,nports
+          DO 340 jj=1,irempo
+            IF (cports(ji).eq.clrport(jj).and.
+     *          myport(1,ji)+irport(1,jj).eq.1) THEN
+                IF ((mydist(1,ji).eq.irdist(1,jj).and.
+     *              myport(4,ji).ne.irport(4,jj)).or.
+     *              (mydist(CLIM_Strategy,ji).eq.CLIM_Serial.and.
+     *              myport(4,ji).lt.irport(4,jj)).or.
+     *              (irdist(CLIM_Strategy,jj).eq.CLIM_Serial.and.
+     *              irport(4,jj).lt.myport(4,ji))) THEN
+                    kinfo = CLIM_IncSize
+                    WRITE(nulprt,FMT='(A,A,A,I2,A,I2,A,I2,I2)')
+     *                  'Start - WARNING Incompatible sizes - field',
+     *                  cports(ji),'model ',mynum,' and model ',
+     *                  isdmod,': ',myport(4,ji),irport(4,jj)
+                ELSEIF (myport(2,ji).ne.irport(2,jj)) THEN
+                    kinfo = CLIM_BadType
+                    WRITE(nulprt,FMT='(A,A,A,I2,A,I2,A,I2,I2)')
+     *                  'Start - WARNING Incompatible types - field',
+     *                  cports(ji),'model ',mynum,' and model ',
+     *                  isdmod,': ',myport(2,ji),irport(2,jj)
+                ELSE
+                    IF (myport(1,ji).eq.CLIM_Out) THEN
+                        incp   = ig_ntime / ig_frqmin + 1
+                        ipotag = CLIM_MaxTag - (ji-1)*incp - 1
+                    ELSE
+                        incp   = ig_ntime / ig_frqmin + 1
+                        ipotag = CLIM_MaxTag - (jj-1)*incp - 1
+                    ENDIF
+                    IF ((ipotag-incp).lt.il_maxtag) THEN
+                        il_maxtag = ipotag - incp
+                    ENDIF
+                    IF (mydist(CLIM_Strategy,ji).ne.CLIM_Serial.and
+     *               .irdist(CLIM_Strategy,jj).ne.CLIM_Serial) THEN
+                        IF (mydist(CLIM_Strategy,ji).ne.
+     *                      irdist(CLIM_Strategy,jj)) THEN
+                            CALL halte('STOP in Clim_Start_MPI')
+                        ELSE
+                            IF (mydist(CLIM_Segments,ji).eq.
+     *                      irdist(CLIM_Segments,jj)) THEN
+                                nsegid = 0                            
+                                DO  is=1,2*mydist(CLIM_Segments,ji)
+                                  IF (mydist(CLIM_Segments+is,ji).eq.
+     *                               irdist(CLIM_Segments+is,jj)) THEN 
+                                      nsegid = nsegid + 1
+                                  ENDIF
+                                END DO
+                                IF (nsegid.eq.
+     *                              (2*mydist(CLIM_Segments,ji))) THEN
+                                    nlinks = nlinks + 1
+                                    ipos   = 5
+                                    myport(ipos,ji)=myport(ipos,ji)+ 1
+                                    myport(ipos+myport(ipos,ji),ji)
+     *                                     = nlinks
+                                    mylink(1,nlinks) = isdmod
+                                    mylink(2,nlinks) = modtid(isdmod)
+                                    mylink(3,nlinks) = ipotag
+                                    mylink(4,nlinks) = 1
+                                    mylink(5,nlinks) = 0
+                                    mylink(6,nlinks) = myport(4,ji)
+                                    WRITE(nulprt,FMT='(A,A)')
+     *                                  'Start - LINK ',cports(ji)
+                                    WRITE(nulprt,FMT='(A,I2,A,I1,A,I2,
+     *                                 A,I1,A,I10,A,I10)')
+     *                                  'Start - [model ',
+     *                                  mynum,'/io ',myport(1,ji),'] - 
+     *                                    [model ',
+     *                                  isdmod,'/io ',irport(1,jj),'] 
+     *                                   using tags ',
+     *                                  ipotag,' to ',ipotag-incp+1
+                                ENDIF    
+                            ENDIF
+                        ENDIF
+                    ELSE                    
+                        nlinks = nlinks + 1
+                        ipos   = 5
+                        myport(ipos,ji) = myport(ipos,ji) + 1
+                        myport(ipos+myport(ipos,ji),ji) = nlinks
+                        mylink(1,nlinks) = isdmod
+                        mylink(2,nlinks) = modtid(isdmod)
+                        mylink(3,nlinks) = ipotag
+                        mylink(4,nlinks) = 1
+                        mylink(5,nlinks) = 0
+                        mylink(6,nlinks) = myport(4,ji)
+                        IF (mydist(CLIM_Strategy,ji).eq.CLIM_Serial.and
+     *                   .irdist(CLIM_Strategy,jj).ne.CLIM_Serial) THEN
+                            mylink(4,nlinks) = irdist(CLIM_Segments,jj)
+                            DO 330 is=1,2*irdist(CLIM_Segments,jj)
+                              mylink(4+is,nlinks) = irdist
+     *                                      (CLIM_Segments+is,jj)
+ 330                        CONTINUE
+                        ENDIF
+                        WRITE(nulprt,FMT='(A,A)')
+     *                      'Start - LINK ',cports(ji)
+                        WRITE(nulprt,FMT='(A,I2,A,I1,A,I2,A,
+     *                       I1,A,I10,A,I10)')
+     *                      'Start - [model ',
+     *                      mynum,'/io ',myport(1,ji),'] - [model ',
+     *                      isdmod,'/io ',irport(1,jj),'] using tags ',
+     *                      ipotag,' to ',ipotag-incp+1
+                    ENDIF                    
+                ENDIF
+            ENDIF
+ 340      CONTINUE
+ 350    CONTINUE
+c
+        WRITE (nulprt,FMT='(A)') 'Start - -'
+ 380  CONTINUE
+c
+c     MPI_wait on the above MPI_Isend so to not change the content of pkwork
+c     before the sending is complete.
+      irc = 0
+      DO 420 ji = 0 , ncplprocs-1
+        IF ( ji .NE. mynum ) THEN
+            CALL MPI_Wait ( ireq(irc), istatus, info )
+            WRITE (nulprt, FMT='(A)') 'After MPI_wait'
+            irc = irc+1
+        ENDIF 
+ 420  CONTINUE
+      DEALLOCATE(ireq)
+c
+c*    correct execution
+c
+      nexit = 1
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      WRITE (nulprt,FMT='(A)') 'Returning from Start-mpi  -- '
+      CALL FLUSH(nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/CLIM_Stepi.F
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/CLIM_Stepi.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/CLIM_Stepi.F	(revision 1677)
@@ -0,0 +1,70 @@
+      SUBROUTINE CLIM_Stepi(cdnam,kinfo)
+c
+c*    *** Stepi ***   CLIM 2.0
+c
+c     purpose:
+c     --------
+c        retrieve info on cdnam models time steps
+c
+c     interface:
+c     ----------
+c        cdnam   : character string name of the model
+c        kinfo  : output status or nbr of procs implied 
+c                 in the coupling for cdnam
+c
+c     lib mp:
+c     -------
+c        mpi-2
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Arnaud Caubel - FECIT (08/02 - removed some arguments)
+c     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_kinds_oasis
+      USE mod_clim
+      USE mod_comclim
+c     ----------------------------------------------------------------
+      CHARACTER*(*) cdnam
+      INTEGER (kind=ip_intwp_p)	    kinfo
+c     ----------------------------------------------------------------
+      CHARACTER*32  cltest
+      INTEGER (kind=ip_intwp_p)       ip
+c     ----------------------------------------------------------------
+c
+c*    0. First Check
+c     --------------
+c
+      WRITE (nulprt, FMT='(A)')'Stepi called'
+      IF ( nexit.ne.1 ) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt, FMT='(A)') 'Stepi - should not be called'
+          GO TO 1010
+      ENDIF
+      kinfo = CLIM_Ok
+c
+c*    1. check for the cdnam model in my list
+c     --------------------------------------
+c
+      kinfo = CLIM_BadName
+c
+      cltest=cdnam
+c
+      kinfo=0
+      DO 100 ip=0,ncplprocs-1
+         IF ( cnames(ip).eq.cltest ) THEN
+C IF more than one process for the model, 
+C info coming from last proc is kept as output
+            kinfo = kinfo + 1
+         ENDIF
+  100 CONTINUE
+c
+ 1010 CONTINUE
+c     ----------------------------------------------------------------
+c
+      CALL FLUSH(nulprt)
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/clim/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/Makefile	(revision 1677)
@@ -0,0 +1,56 @@
+
+SRCS1 =  $(shell ls ../../../../src/lib/clim/src/*.F90)
+OBJS1 =  $(patsubst ../../../../src/lib/clim/src/%.F90, %.o, $(SRCS1))
+
+SRCS3 =  $(shell ls ../../../../src/lib/clim/src/*.F)
+OBJS3 =  $(patsubst ../../../../src/lib/clim/src/%.F, %.o, $(SRCS3))
+
+VPATH =	./:../../../../src/lib/clim/src:\
+	   ../../../../src/mod/$(COUPLE)/src
+
+LIBRARY	= ../../../lib/libclim.${CHAN}.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS1) $(OBJS3)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS1) $(OBJS3)
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+
+#
+# ALL dependencies ...
+#
+
+mod_clim.o: mod_kinds_oasis.o
+mod_comclim.o: mod_clim.o mod_kinds_oasis.o
+mod_clim_def.o: mod_kinds_oasis.o mod_clim.o mod_comclim.o
+CLIM_Export.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Import.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Init_Oasis.o: mod_clim.o mod_comclim.o mod_parameter.o \
+	mod_timestep.o mod_string.o mod_unitncdf.o \
+	mod_kinds_oasis.o mod_hardware.o mod_calendar.o mod_label.o
+CLIM_Parse.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Quit.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Start.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Start_MPI.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
+CLIM_Stepi.o: mod_clim.o mod_comclim.o mod_kinds_oasis.o
Index: CPL/oasis3/trunk/src/lib/clim/src/mod_clim.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/mod_clim.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/mod_clim.F90	(revision 1677)
@@ -0,0 +1,105 @@
+MODULE mod_clim
+!
+! -- clim.h   18-08-95   Version 2.0   Author: Laurent Terray
+!    ******
+!             26-10-99   Version 2.4   Jean Latour (F.S.E.) MPI-2 support
+!@
+! -- mod_clim.f90  12-06-02  Version 2.5   A. Caubel 
+!    ************
+!
+!@  Contents : variables related to the CLIM library
+!@  --------
+!@ For complete definition, see the CLIM manual
+!@
+!
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+!
+  USE mod_kinds_oasis
+!
+  INTEGER(kind=ip_intwp_p) :: CLIM_MaxTag
+!
+!-----Parameter sizes
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Void = 0  
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_MaxSegments = 338 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_ParSize = 2*CLIM_MaxSegments+2 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Clength = 32 
+!
+!-----Dimension of buffer for packing / unpacking messages with MPI
+!
+  INTEGER(kind=ip_intwp_p) :: ig_maxtype, ig_CLIMmax
+!
+!-----Logical for buffered send
+!
+  LOGICAL :: lg_bsend
+!
+!-----Ports status
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_In      = 1 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Out     = 0 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_InOut   = 2 
+!
+!----Field local transformation
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_instant = 1
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_average = 2
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_accumul = 3
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_min = 4
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_max = 5
+!
+!-----Parallel distribution
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Strategy = 1 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Segments = 2 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Serial   = 0 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Apple    = 1 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Box      = 2 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Orange   = 3 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Offset   = 2 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Length   = 3 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_SizeX    = 3 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_SizeY    = 4 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_LdX      = 5 
+!
+!-----Datatypes
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Integer = 1 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Real    = 4  
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Double  = 8 
+!
+!-----Quit parameters
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_ContPvm = 0 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_StopPvm = 1 
+!
+!-----Error Codes
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_MaxCodes  = -22 
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Ok	 = 0 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_FastExit  = -1 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_BadName   = -2 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_BadPort   = -3 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_BadType   = -4 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_DoubleDef = -5 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_NotStep   = -6 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_IncStep   = -7 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_IncSize   = -8 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_NotClim   = -9 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_TimeOut   = -10 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Pvm       = -11 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_FirstCall = -12 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_PbRoute   = -13 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Group     = -14 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_BadTaskId = -15 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_NoTask    = -16 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_InitBuff  = -17 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Pack      = -18 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Unpack    = -19 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Down      = -20 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_PvmExit   = -21 
+  INTEGER(kind=ip_intwp_p), PARAMETER :: CLIM_Mpi       = -22 
+!
+#endif
+END MODULE mod_clim
+
Index: CPL/oasis3/trunk/src/lib/clim/src/mod_clim_def.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/mod_clim_def.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/mod_clim_def.F90	(revision 1677)
@@ -0,0 +1,241 @@
+MODULE mod_clim_def
+!
+!
+!**** DEFINE
+!
+!     Purpose:
+!      Routines CLIM_Define and CLIM_Defport are now in a module.
+!     
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses assumed shape array method to dimension local arrays.        
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/06     created
+!
+!*-----------------------------------------------------------------------
+
+CONTAINS
+!
+ SUBROUTINE CLIM_Define(id_nports, cdport,kinout,ktype,kparal,kinfo)
+!
+!*    *** Define ***   CLIM 2.0
+!
+!     purpose:
+!     --------
+!        define a port
+!
+!     interface:
+!     ----------
+!        id_nports : port number of the field
+!        cdport : symbolic name of the field
+!        kinout : port status in/out
+!        ktype  : type of data
+!        kparal : type of parallel decomposition
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Arnaud Caubel - Fecit
+!     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+   USE mod_kinds_oasis
+   USE mod_clim
+   USE mod_comclim
+!     ----------------------------------------------------------------
+   INTEGER(kind=ip_intwp_p)       kinout, ktype, kinfo, id_nports
+   INTEGER(kind=ip_intwp_p), DIMENSION(:) :: kparal
+   CHARACTER*(*) cdport
+!     ----------------------------------------------------------------
+!
+!*    0. First Check
+!     --------------
+!
+   IF ( nexit.NE.1 ) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Define - should not be called'
+       GO TO 1010
+   ENDIF
+   kinfo = CLIM_Ok
+!
+!*    1. define the port
+!     ------------------
+!
+   WRITE(nulprt,*) 'Define - port name, status : ',cdport,kinout
+   WRITE(nulprt,*) 'Define - data type: ',ktype
+!
+   IF ( kinout.EQ.CLIM_InOut ) THEN
+       CALL CLIM_Defport (id_nports,cdport, CLIM_In, ktype, kparal, kinfo )
+       IF (kinfo.EQ.CLIM_Ok) THEN
+           CALL CLIM_Defport (id_nports,cdport,CLIM_Out,ktype,kparal,kinfo )
+       ENDIF
+   ELSE
+       CALL CLIM_Defport ( id_nports,cdport, kinout,  ktype, kparal, kinfo )
+   ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+   CALL FLUSH(nulprt)
+#endif
+   RETURN
+ END SUBROUTINE CLIM_Define
+!
+! ====================================================================
+
+ SUBROUTINE CLIM_Defport(id_nports,cdport,kinout,ktype,kparal,kinfo)
+!
+!*    *** Define ***   CLIM 2.2
+!
+!     purpose:
+!     --------
+!        define a port
+!
+!     interface:
+!     ----------
+!        id_nports : port number of the field
+!        cdport : symbolic name of the field
+!        kinout : port status in/out
+!        ktype  : type of data
+!        kparal : type of parallel decomposition
+!        kinfo  : output status
+!
+!     lib mp:
+!     -------
+!        mpi-2
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.   (mpi-2)
+!
+!     ----------------------------------------------------------------
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+   USE mod_kinds_oasis
+   USE mod_clim
+   USE mod_comclim
+!     ----------------------------------------------------------------
+   INTEGER(kind=ip_intwp_p)       kinout, ktype, kinfo
+   INTEGER(kind=ip_intwp_p), DIMENSION(:) :: kparal
+   CHARACTER*(*) cdport
+!     ----------------------------------------------------------------
+   INTEGER(kind=ip_intwp_p)     ip, is, id_nports
+   INTEGER(kind=ip_intwp_p)       il_testvar
+   REAL(kind=ip_realwp_p)          rl_testvar
+   REAL(kind=ip_double_p)  dl_testvar
+   CHARACTER*32  cltest
+!     ----------------------------------------------------------------
+!
+!*    1. check if this port already exist
+!     -----------------------------------
+!
+   cltest= cdport
+   il_testvar = 0
+   rl_testvar = 0.0
+   dl_testvar = 0.0
+!
+   DO ip=1,nports
+     IF (cltest.EQ.cports(ip).AND.kinout.EQ.myport(1,ip)) THEN
+         kinfo = CLIM_DoubleDef
+         WRITE(nulprt,FMT='(A,A)') &
+            'Define - WARNING - duplicate definition of port ', & 
+            cdport
+         GO TO 1010
+     ENDIF
+   ENDDO
+!
+!*    2. save arguments as half a link
+!     --------------------------------
+!
+   nports = nports + 1
+   id_nports = nports
+   cports(nports) = cdport
+!
+   myport(1,nports) = kinout
+   myport(5,nports) = 0
+!
+!   IF ( ktype.EQ.CLIM_Integer ) THEN
+!       myport(2,nports) = CLIM_Integer
+!       myport(3,nports) = kind(il_testvar)
+!   ELSEIF ( ktype.EQ.CLIM_Real ) THEN
+   IF ( ktype.EQ.CLIM_Real ) THEN
+       myport(2,nports) = CLIM_Real
+       myport(3,nports) = kind(rl_testvar)
+!   ELSEIF ( ktype.EQ.CLIM_Double ) THEN
+!       myport(2,nports) = CLIM_Double
+!       myport(3,nports) = kind(dl_testvar)
+   ELSE
+       kinfo = CLIM_BadType
+       WRITE(nulprt,FMT='(A,I4)') &
+          'Define - WARNING - Bad data type:',ktype
+   ENDIF
+!
+   IF (kparal(CLIM_Strategy).EQ.CLIM_Serial) THEN
+!
+       mydist(CLIM_Strategy,nports)   = CLIM_Serial
+       mydist(CLIM_Segments,nports)   = 1
+       mydist(CLIM_Segments+1,nports) = 0
+       mydist(CLIM_Segments+2,nports) = kparal(CLIM_Length)
+       myport(4,nports) = kparal(CLIM_Length)
+!
+   ELSEIF (kparal(CLIM_Strategy).EQ.CLIM_Apple) THEN
+!
+       mydist(CLIM_Strategy,nports)   = CLIM_Apple
+       mydist(CLIM_Segments,nports)   = 1
+       mydist(CLIM_Segments+1,nports) = kparal(CLIM_Offset)
+       mydist(CLIM_Segments+2,nports) = kparal(CLIM_Length)
+       myport(4,nports) = kparal(CLIM_Length)
+!
+   ELSEIF (kparal(CLIM_strategy).EQ.CLIM_Box) THEN
+!
+       mydist(CLIM_Strategy,nports)   = CLIM_Box
+       mydist(CLIM_Segments,nports)   = kparal(CLIM_SizeY)
+       DO is=1,kparal(CLIM_SizeY)
+         mydist(CLIM_Segments+2*is-1,nports) = &
+            kparal(CLIM_Offset) + (is-1) * kparal(CLIM_LdX)
+         mydist(CLIM_Segments+2*is,nports) = kparal(CLIM_SizeX)
+       ENDDO
+       myport(4,nports) = kparal(CLIM_SizeX) * kparal(CLIM_SizeY)
+!
+   ELSEIF (kparal(CLIM_strategy).EQ.CLIM_Orange) THEN
+!
+       mydist(CLIM_Strategy,nports)   = CLIM_Orange
+       mydist(CLIM_Segments,nports)   = kparal(CLIM_Segments)
+       myport(4,nports) = 0
+       DO is=1,2*kparal(CLIM_Segments)
+         mydist(CLIM_Segments+is,nports) = kparal(CLIM_Segments+is)
+         IF (MOD(is,2).EQ.0) THEN
+             myport(4,nports) = myport(4,nports) + &
+                kparal(CLIM_Segments+is)
+         ENDIF
+       ENDDO
+   ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+   CALL FLUSH(nulprt)
+#endif
+   RETURN
+ END SUBROUTINE CLIM_Defport
+END MODULE mod_clim_def
Index: CPL/oasis3/trunk/src/lib/clim/src/mod_comclim.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/clim/src/mod_comclim.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/clim/src/mod_comclim.F90	(revision 1677)
@@ -0,0 +1,99 @@
+MODULE mod_comclim
+!
+!     - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!
+!*    =comclim.h=  CLIM 1.1 internal include file
+!                  Coupling Library for Interfacing Models
+!
+!     - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+  USE mod_kinds_oasis
+  USE mod_clim
+!
+!-----Unit number for trace file
+!
+  INTEGER(kind=ip_intwp_p)	:: nulprt
+!
+!-----Models descriptors
+!
+!     ncplprocs: total number of processes involved in the coupling
+!                counting oasis process (1)
+  INTEGER(kind=ip_intwp_p) :: ncplprocs, mynum, mytid
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: modtid
+!  INTEGER*4 :: mynummod
+!
+!-----Minimum exchange frequency, total time of the simulation, total 
+!     number of fields exchanged in the simulation and local communicator of 
+!     each component.
+! 
+  INTEGER(kind=ip_intwp_p) :: ig_frqmin, ig_ntime, ig_clim_nfield, ig_local_comm
+!
+!-----Ports descriptors
+!
+  INTEGER(kind=ip_intwp_p) :: nports 
+  INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: myport, irport
+  INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: mydist, irdist
+!
+!
+!-----Links descriptors
+!
+  INTEGER(kind=ip_intwp_p) :: nlinks 
+  INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: mylink
+!
+!-----Data encoding
+!
+  INTEGER(kind=ip_intwp_p) :: mycode
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ncode
+!
+!-----Inquiry descriptors
+!
+  INTEGER(kind=ip_intwp_p) :: nbsend, nbrecv
+!
+!-----Time out stuff
+!
+  INTEGER(kind=ip_intwp_p) :: ntiret, ntiogp, ntiout, nexit
+!
+!-----Timesteps descriptors
+!
+  INTEGER(kind=ip_intwp_p) :: mystep, mystdt, myfcpl
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ig_nstep
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nstdt
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nfcpl 
+!
+!-----Delta time between models
+!
+  REAL(kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: delta
+  REAL(kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: delte
+!
+!-----Character strings
+!
+  CHARACTER*8 :: cgroup
+  CHARACTER*12 :: cnaprt
+  CHARACTER*32, DIMENSION(:), ALLOCATABLE :: cports, clrport
+  CHARACTER*32 :: cmynam
+  CHARACTER*32, DIMENSION(:), ALLOCATABLE :: cnames  
+  CHARACTER*4 :: ctype
+!
+!-----Packing area for Export and Import
+!
+  REAL(kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: pkwork  
+!
+!
+!-----CLIM/MPI2 specific variable
+!-----mpi_rank :  Rank of process in MPI communicator
+!-----mpi_size :  Size of communicator
+!-----mpi_err :  Error code of MPI calls
+!-----mpi_comm :  Communicator handle
+
+  INTEGER(kind=ip_intwp_p) :: mpi_rank, mpi_size, mpi_err, mpi_comm
+
+!
+!-----Buffer for MPI_BSend
+!
+  REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: dg_bufsend
+!
+!
+#endif
+END MODULE mod_comclim
+
+
Index: CPL/oasis3/trunk/src/lib/fscint/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/fscint/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/fscint/src/Makefile	(revision 1677)
@@ -0,0 +1,41 @@
+
+SRCS4 =  $(shell ls ../../../../src/lib/fscint/src/*.f)
+OBJS4 =  $(patsubst ../../../../src/lib/fscint/src/%.f, %.o, $(SRCS4))
+
+VPATH =	../../../../src/lib/fscint/src:../../../../src/mod/$(COUPLE)/src:
+
+LIBRARY	= ../../../lib/libfscint.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS4)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS4)
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# ALL dependencies ...
+#
+
+memoir.o: mod_kinds_oasis.o
+discendo.o: memoir.o
+
Index: CPL/oasis3/trunk/src/lib/fscint/src/discendo.f
===================================================================
--- CPL/oasis3/trunk/src/lib/fscint/src/discendo.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/fscint/src/discendo.f	(revision 1677)
@@ -0,0 +1,3701 @@
+C* ----------------------------------------------------------------------
+C 
+C                            FSCINT
+C                            ------
+C               *******************************
+C               * OASIS INTERPOLATION PACKAGE *
+C               * ----- ------------- ------- *
+C               *******************************
+C 
+C* This is the Fast Scalar INTerpolator package initially written by Yves
+C* Chartier and colleagues at RPN Canada. This software has been adapted
+C* to the OASIS structure and provides several interpolation techniques
+C* (see oasis documentation for details). This package has been split in
+C* 2 files: discendo.f and semper.f (for people not fluent in latin,
+C* "semper discendo" means "always learning" ... ;-)...). discendo.f
+C* contains all the interpolation related routines while semper.f has
+C* the memory allocation using fortran 90 features.
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------
+C       1.1       L. Terray      94/06/01  Introduced
+C       1.1       P. Braconnot   94/06/15  Extend longitude range for Z grids
+C       2.0       L. Terray      96/09/25 
+C       2.2       G. Risari      97/12/01  new routine names 
+C       2.2       A.P, S.V, L.T  97/12/14  Change memory allocation
+C       2.3       L. Terray      99/09/15  Introduction of Y grid and cleaning
+C       2.4       E. Maisonnave  00/07/03  REAL NEWAXEY(I1:I2) (line 2806)
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      FUNCTION FINDLON(VAL, TABLEAU, NBELEM, TMP)
+C* ----------------------------------------------------------------------
+C
+C* New function to account for strange AGCM Z-grids (longitude<0 or >360)
+C
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) FINDLON
+      INTEGER (kind=ip_intwp_p) NBELEM
+      REAL(kind=ip_realwp_p) VAL
+      REAL(kind=ip_realwp_p) TABLEAU(NBELEM)
+      REAL(kind=ip_realwp_p) TMP
+      INTEGER (kind=ip_intwp_p) DEBUT, MILIEU, FIN
+C
+C* Get longitudes in the right interval
+C
+      IF( VAL .GT. TABLEAU(NBELEM)) THEN
+          TMP = VAL - 360.
+      ELSEIF( VAL .LT. TABLEAU(1)) THEN
+          TMP = VAL + 360.
+      ELSE
+          TMP = VAL
+      ENDIF
+C
+C* Find grid point coordinates
+C
+      DEBUT = 1
+      FIN = NBELEM
+      MILIEU = (DEBUT+FIN)*0.5
+23000 IF( (MILIEU.NE. DEBUT))THEN
+         IF( TMP .LE. TABLEAU(MILIEU) ) THEN
+            FIN   = MILIEU
+         ELSE 
+            DEBUT = MILIEU
+         ENDIF 
+         MILIEU = (DEBUT+FIN)*0.5
+         GOTO 23000
+      ENDIF 
+      FINDLON = MILIEU
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      FUNCTION CHERCHE(VAL, TABLEAU, NBELEM)
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) CHERCHE
+      INTEGER (kind=ip_intwp_p) NBELEM
+      REAL(kind=ip_realwp_p) VAL
+      REAL(kind=ip_realwp_p) TABLEAU(NBELEM)
+      INTEGER (kind=ip_intwp_p) DEBUT, MILIEU, FIN
+      DEBUT = 1
+      FIN = NBELEM
+      MILIEU = (DEBUT+FIN)*0.5
+23000 IF( (MILIEU.NE. DEBUT))THEN
+         IF( (VAL.LE. TABLEAU(MILIEU)))THEN
+            FIN   = MILIEU
+         ELSE 
+            DEBUT = MILIEU
+         ENDIF 
+         MILIEU = (DEBUT+FIN)*0.5
+         GOTO 23000
+      ENDIF 
+      CHERCHE = MILIEU
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE CHKXTRAP(PX, PY, NPTS, NI, NJ)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) NPTS, NI, NJ, OFFL, OFFR
+      REAL(kind=ip_realwp_p) PX(NPTS), PY(NPTS)
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      INTEGER (kind=ip_intwp_p) N, I, J
+      FLGXTRAP = .FALSE.
+      IF( (ORDINT.EQ. 3))THEN
+         OFFR = 3
+         OFFL = 2
+      ELSE 
+         OFFR = 1
+         OFFL = 0
+      ENDIF 
+      DO 23002 N=1, NPTS
+         I = INT(PX(N))
+         J = INT(PY(N))
+         IF( (I.LT. OFFL.OR. J.LT. OFFL.OR. I.GT. (NI-OFFR).OR. J
+     $   .GT. (NJ-OFFR)))THEN
+            FLGXTRAP = .TRUE.
+         ENDIF 
+23002 CONTINUE 
+      IF( (FLGXTRAP.AND. CODXTRAP.EQ. ABORT))THEN
+         WRITE(6, *)
+     $'*****************************************************************
+     $****'
+         WRITE(6, *)
+     $       'target grid contains points outside of source grid'
+         WRITE(6, *)  'We stop the program'
+         WRITE(6, *)
+     $'*****************************************************************
+     $****'
+         STOP
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE DGAUSS (N,ROOTS,KASE)
+      USE mod_kinds_oasis
+      REAL(kind=ip_realwp_p) ROOTS(*)
+C
+C AUTEUR- D. ROBERTSON
+C
+C OBJET(DGAUSS)
+C     - CALCULATES THE ZEROES OF THE ORDINARY LEGENDRE
+C     POLYNOMIAL OF ORDER N,  I.E. DEFINE GAUSSIAN GRID
+C
+C ALGORITHME
+C     - THE POSITIVE ROOTS ARE APPROXIMATED BY THE BEST
+C     ASYMPTOTIC FORMULA AVAILABLE TO THE AUTHOR, FOUND IN
+C     ABRAMOWITZ AND STEGUN "HANDBOOK OF MATHEMATICAL FUNCTIONS".
+C     CHAPTER 22 FORMULA 22.16.6.
+C     NEWTON'S METHOD IS USED TO REFINE THE GUESS TO PRECISION
+C     DEFINED BY THE CONSTANT TOL.  SINCE THE ROOTS ARE OF ORDER
+C     OF MAGNITUDE UNITY, ABSOLUTE PRECISION IS ADEQUATE, RATHER
+C     THAN A RELATIVE TEST.
+C     A STANDARD IDENTITY IS USED TO DETERMINE THE DERIVATIVE OF
+C     THE POLYNOMIAL IN TERMS OF THE VALUES OF P(N;X),P(N-1;X).
+C     (X**2-1.0)*(DP/DX)=N*(X*P(N;,X)-P(N-1;X)).
+C     SEE ABRAMOWITZ AND STEGUN FORMULA 22.8.5
+C     NOTE THAT IN CONTRAST TO OTHER FORMULAS THIS REQUIRES ONLY
+C     2 EVALUATIONS OF A LEGENDRE POLYNOMIAL PER ITERATION.
+C     NOTE THAT THE COORDINATE USED IS CONVENTIONALLY REFERRED TO
+C     AS MU=COS(THETA), RUNNING FROM +1 TO -1, FOR THETA FROM 0 TO
+C     PI. THE NEGATIVE ROOTS ARE  FILLED BY SYMMETRY.
+C     FOR KASE=GLOBAL, ALL N ROOTS ARE FOUND, WHILE FOR
+C     DASE=NORTH/SOUTH ONLY THE +VE/-VE ROOTS ARE FOUND,
+C     (INCLUDING 0 IF N IS ODD)  I.E. N/2+MOD(N,2) ROOTS.
+C
+C
+C APPEL - CALL DGAUSS(N,ROOTS,KASE)
+C
+C ARGUMENTS
+C     IN    - N     - ORDER OF THE POLYNOMIALS
+C     OUT   - ROOTS - ARRAY CONTAINING THE ZEROES OF THE
+C     ORDINARY LEGENDRE POLYNOMIALS
+C     IN    - KASE  - =0, GLOBAL
+C     =1, NORTH
+C     =2, SOUTH
+C 
+C MODULES APPELES
+C     - ORDLEG
+C
+C ----------------------------------------------------------------------
+C
+C     THE ANSWERS ARE RETURNED IN ROOTS.
+
+      REAL(kind=ip_realwp_p) NORMN,NORMNM
+      INTEGER (kind=ip_intwp_p) GLOBAL,NORTH,SOUTH,NORD,SUD
+      PARAMETER(GLOBAL=0,NORTH=1,NORD=1,SOUTH=2,SUD=2)
+      DATA TOL /1.0E-06/
+C
+C     RDTODG = 180/PI, DGTORD = PI/180
+C
+      DATA PI   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+C     ORDLEG RETURNS POLYNOMIALS NORMALIZED TO UNIT INTEGRAL.
+C     NORMN,NORMNMN RESTORE THE CONVENTION NORMALIZATION, P(N;1.0)=1.0.
+C* ----------------------------------------------------------------------
+
+      NORMN =SQRT(2.0/(2.0*N+1.0))
+      NORMNM=SQRT(2.0/(2.0*N-1.0))
+      L = N/2
+C
+C     CALCULATE ASYMPTOTIC APPROXIMATION
+C
+      DO 23000 I=1,L
+         IF((KASE.NE.SOUTH))THEN
+            J = I
+         ENDIF 
+         IF((KASE.EQ.SOUTH))THEN
+            J=I+L+MOD(N,2)
+         ENDIF 
+         T = (4*J-1)*PI/FLOAT(4*N+2)
+         IF((KASE.NE.SOUTH))THEN
+            IRT = I
+         ENDIF 
+         IF((KASE.EQ.SOUTH))THEN
+            IRT = I + MOD(N,2)
+         ENDIF 
+         ROOTS(IRT)=COS(T+1.0/(8.0*FLOAT(N**2)*TAN(T)))
+
+C
+23000 CONTINUE 
+      DO 23010 I=1,L
+
+C
+C     REPEAT 1 NEWTON ITERATION
+C     **  BEGIN
+C
+6        CALL ORDLEG(G,ROOTS(I),N)
+         CALL ORDLEG(GM,ROOTS(I),N-1)
+         PN = NORMN*G
+         PNM= NORMNM*GM
+C
+C     **         GUESS(K+1)=GUESS(K)-P/(DP/DX)
+C
+
+         RDPDX = (ROOTS(I)**2-1.0)/(N*(ROOTS(I)*PN-PNM))
+         DELTA = -PN*RDPDX
+         ROOTS(I) = ROOTS(I)+DELTA
+         IF((ABS(DELTA).GT.TOL))THEN
+            GO TO 6
+C
+C     **  END UNTIL ABS(DELTA).LE.TOL
+C
+
+         ENDIF 
+         ROOTS(N+1-I) = -ROOTS(I)
+
+C
+23010 CONTINUE 
+      IF((MOD(N,2).EQ.0))THEN
+         RETURN
+      ENDIF 
+      IF((KASE.NE.SOUTH))THEN
+         IRT = L+1
+      ENDIF 
+      IF((KASE.EQ.SOUTH))THEN
+         IRT = 1
+      ENDIF 
+      ROOTS(IRT) = 0.0
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE GAUSS(NRACP,RACP,PG,SIA,RAD,PGSSIN2,SINM1,SINM2,
+     $SIN2)
+C* -----------------------------------------------------------------------
+C     CALCULE LES NRACP RACINES POSITIVES DU POLYNOME DE LEGENDRE DE
+C     DEGRE 2*NRACP (ICI-APRES NOTE PN) DEFINI SUR L INTERVALLE DES
+C     COLATITUDES ALLANT DE 0 (POLE NORD) A PI (POLE SUD). ON SAIT QUE
+C     LES 2*NRACP RACINES SONT ANTI-SYMETRIQUES P/R A L EQUATEUR PI/2,
+C     ETANT POSITIVES ENTRE COLAT=0 ET COLAT =PI/2.
+C     ON CALCULE ENSUITE LES POIDS DE GAUSS ASSOCIES AUX COLATITUDES
+C     GAUSSIENNES (ICI APRES NOTEES CG), AINSI QU UN CERTAIN NOMBRE DE
+C     FONCTIONS DE CG DEFINIES PLUS LOIN. ON RAPPELLE ENFIN QUE LA LATI-
+C     TUDE LAT=COLAT-PI/2, ET DONC QUE SIN(LAT)=COS(COLAT).
+C     NRACP        : NOMBRE DE RACINES POSITIVES DU POLYNOME DE LEGENDRE
+C                  : DE DEGRE 2*NRACP.
+C     RACP(I)      : RACINES DE PN, =SIN(LG)=COS(CG).
+C     PG(I)        : POIDS DE GAUSS CORRESPONDANTS.
+C     SIA(I)       : SIN(CG)=COS(LG).
+C     RAD(I)       : COLATITUDE CG EN RADIANS.
+C     PGSSIN2(I)   : POIDS DE GAUSS / (SIN(CG))**2.
+C     SINM1(I)     : (SIN(CG))**-1.
+C     SINM2(I)     : (SIN(CG))**-2.
+C     VOIR NST 8, CHAP. A, PP.1-7, ET APPENDICE D12, PP. 26-27.
+C     VERSION REVISEE PAR MICHEL BELAND, 9 DECEMBRE 1980.
+C     *****************************************************************
+C
+C
+      USE mod_kinds_oasis
+C     -----------------------------------------------------------------
+
+      DIMENSION RACP(1),PG(1),SIA(1),RAD(1),PGSSIN2(1),SINM1(1),
+     $SINM2(1),SIN2(1)
+C     --------------------------------------------------------------
+C
+C     ON DEMANDE UNE PRECISION DE 1.E-13 POUR LES RACINES DE PN.
+C
+
+      XLIM=1.E-6
+      PI = 3.14159265358979323846
+      IR = 2*NRACP
+      FI=FLOAT(IR)
+      FI1=FI+1.
+      FN=FLOAT(NRACP)
+C
+C     ON UTILISE UNE FORMULE ASYMPTOTIQUE POUR OBTENIR LES VALEURS
+C     APPROXIMATIVES DES COLATITUDES GAUSSIENNES
+C     CG(I) = (PI/2) * (2*I-1)/(2*NRACP).
+C     VOIR ABRAMOWITZ AND STEGUN, P. 787, EQU. 22.16.6 .
+C
+
+      DO 23000 I=1,NRACP
+         DOT=FLOAT(I-1)
+         RACP(I)=-PI*.5*(DOT+.5)/FN + PI*.5
+         RACP(I) =  SIN(RACP(I))
+
+C
+C     ON CALCULE ENSUITE LES CONSTANTES FACTEURS DE P(N+1) ET P(N-1)
+C     DANS L EXPRESSION DE LA PSEUDO-DERIVEE DE PN.
+C
+23000 CONTINUE 
+      DN = FI/SQRT(4.*FI*FI-1.)
+      DN1=FI1/SQRT(4.*FI1*FI1-1.)
+      A = DN1*FI
+      B = DN*FI1
+      IRP = IR + 1
+      IRM = IR -1
+C
+C     ON EMPLOIE ENSUITE UNE METHODE DE NEWTON POUR AUGMENTER LA PREC.
+C     SI RACTEMP EST UNE SOL. APPROXIMATIVE  DE PN(RACP)=0., ALORS LA
+C     SEQUENCE RACTEMP(I+1)=RACTEMP(I)-PN(RACTEMP(I))/DER.PN(RACTEMP(I))
+C     CONVERGE VERS RACP DE FACON QUADRATIQUE.
+C     VOIR ABRAMOWITZ AND STEGUN, P.18, EQU. 3.9.5.
+C     ORDLEG CALCULE LA VALEUR DE PN (RACP) , NORMALISE.
+C
+
+      DO 23002 I=1,NRACP
+42       CALL ORDLEG(G,RACP(I),IR)
+         CALL ORDLEG(GM,RACP(I),IRM)
+         CALL ORDLEG(GP,RACP(I),IRP)
+         GT = (A*GP-B*GM)/(RACP(I)*RACP(I)-1.)
+         RACTEMP = RACP(I) - G/GT
+         GTEMP = RACP(I) - RACTEMP
+         RACP(I) = RACTEMP
+         IF(( ABS(GTEMP).GT.XLIM))THEN
+            GO TO 42
+         ENDIF 
+
+C
+C     ON CALCULE ENSUITE LES POIDS DE GAUSS SELON L ALGORITHME
+C     PG(I) = 2./[(1.-RACP(I)**2)*(DER.PN(RACP(I)))**2].
+C     VOIR ABRAMOWITZ AND STEGUN, P.887, EQU. 25.4.29.
+C     NOTE: ON DOIT MULTIPLIER LA PRECEDENTE FORMULE PAR UN FACTEUR
+C     DE DENORMALISATION, LES PN DONNES PAR ORDLEG ETANT NORMALISES.
+C     ON SE SERT D UNE FORMULE DE RECURRENCE POUR LA DERIVEE DE PN.
+C
+23002 CONTINUE 
+      DO 23006 I=1,NRACP
+         A=2.*(1.-RACP(I)**2)
+         CALL ORDLEG(B,RACP(I),IRM)
+         B = B*B*FI*FI
+         PG(I)=A*(FI-.5)/B
+         RAD(I) =   ACOS(RACP(I))
+         SIA(I) =  SIN(RAD(I))
+         C=(SIA(I))**2
+         SINM1(I) = 1./SIA(I)
+         SINM2(I) = 1./C
+         PGSSIN2(I) =PG(I)/C
+         SIN2(I)=C
+23006 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE GDW2LLW(SPDO,PSIO,XLON,LI,LJ,GRTYP,IG1,IG2,IG3,IG4)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LI,LJ
+      REAL(kind=ip_realwp_p) SPDO(LI,LJ), PSIO(LI,LJ), XLON(LI,LJ)
+      CHARACTER*1 GRTYP
+      INTEGER (kind=ip_intwp_p) IG1,IG2,IG3,IG4
+      EXTERNAL CIGAXG
+C
+C AUTEUR   - Y. CHARTIER - AVRIL 91
+C
+C OBJET(GDW2LLW)
+C         - PASSE DE VENT DE GRILLE (COMPOSANTES U ET V)
+C         - A VITESSE ET DIRECTION (SPEED, PSI)
+C APPEL    - CALL GDW2LLW(SPD,PSI,LI,LJ,IYP,XG1,XG2,XG3,XG4)
+C
+C MODULES  - XGAIG
+C
+C ARGUMENTS
+C  IN/OUT - SPD   - A L'ENTREE CONTIENT LA PSIOTESSE DU VENT ET
+C                   A LA SORTIE LA COMPOSANTE U.
+C  IN/OUT - PSI   - A L'ENTREE CONTIENT LA DIRECTION DU VENT ET
+C                   A LA SORTIE LA COMPOSANTE V.
+C   IN    - LI    - PREMIERE DIMENSION DES CHAMPS SPD ET PSI
+C   IN    - LJ    - DEUXIEME DIMENSION DES CHAMPS SPD ET PSI
+C   IN    - IGTYP  - TYPE DE GRILLE (VOIR OUVRIR)
+C   IN    - XG1   - ** DESCRIPTEUR DE GRILLE (REEL),
+C   IN    - XG2   -    IGTYP = 'N', PI, PJ, D60, DGRW
+C   IN    - XG3   -    IGTYP = 'L', LAT0, LON0, DLAT, DLON,
+C   IN    - XG4   -    IGTYP = 'A', 'B', 'G', XG1 = 0. GLOBAL,
+C                                                 = 1. NORD
+C                                                 = 2. SUD **
+C
+C MESSAGES - "ERREUR MAUVAISE GRILLE (GDW2LLW)"
+C
+C-------------------------------------------------------------
+C
+C
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+
+      INTEGER (kind=ip_intwp_p) I,J
+      REAL(kind=ip_realwp_p) SPD, PSI
+      REAL(kind=ip_realwp_p) XG1,XG2,XG3,XG4
+      IF( (GRTYP.EQ. 'N'))THEN
+         CALL CIGAXG(GRTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+         DO 23002 I=1,LI
+            DO 23004 J=1,LJ
+               SPD=SQRT(SPDO(I,J)*SPDO(I,J)+PSIO(I,J)*PSIO(I,J))
+               IF( (SPD.EQ. 0.0))THEN
+                  PSI= 0.0
+               ELSE 
+                  IF( (SPDO(I,J).EQ. 0.0))THEN
+                     IF( (PSIO(I,J).GE. 0.0))THEN
+                        PSI= XLON(I,J)+XG4-90.0
+                     ELSE 
+                        PSI= XLON(I,J)+XG4+90.0
+                     ENDIF 
+                  ELSE 
+                     PSI=XLON(I,J)+XG4-RDTODG*ATAN2(PSIO(I,J),SPDO(I
+     $               ,J))
+                  ENDIF 
+               ENDIF 
+               PSI=MOD(MOD(PSI,360.0_ip_realwp_p)
+     $             +360.0_ip_realwp_p,360.0_ip_realwp_p)
+               SPDO(I,J)=SPD
+               PSIO(I,J)=PSI
+23004       CONTINUE 
+23002    CONTINUE 
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ. 'S'))THEN
+         CALL CIGAXG(GRTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+         DO 23014 I=1,LI
+            DO 23016 J=1,LJ
+               SPD=SQRT(SPDO(I,J)*SPDO(I,J)+PSIO(I,J)*PSIO(I,J))
+               IF( (SPD.EQ. 0.0))THEN
+                  PSI= 0.0
+               ELSE 
+                  IF( (SPDO(I,J).EQ. 0.0))THEN
+                     IF( (PSIO(I,J).GE. 0.0))THEN
+                        PSI= 90.0 - XLON(I,J)+XG4
+                     ELSE 
+                        PSI= 270.0 - XLON(I,J)+XG4
+                     ENDIF 
+                  ELSE 
+                     PSI= 180.0 - XLON(I,J)+XG4-RDTODG*ATAN2(PSIO(I,
+     $               J),SPDO(I,J))
+                  ENDIF 
+               ENDIF 
+               PSI=MOD(MOD(PSI,360.0_ip_realwp_p)
+     $             +360.0_ip_realwp_p,360.0_ip_realwp_p)
+               SPDO(I,J)=SPD
+               PSIO(I,J)=PSI
+23016       CONTINUE 
+23014    CONTINUE 
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ.'A'.OR.GRTYP.EQ.'B'.OR.GRTYP.EQ.'G'.OR.GRTYP.EQ.
+     $'L'))THEN
+         DO 23026 I=1,LI
+            DO 23028 J=1,LJ
+               SPD=SQRT(SPDO(I,J)*SPDO(I,J)+PSIO(I,J)*PSIO(I,J))
+               IF( (SPD.EQ. 0.0))THEN
+                  PSI= 0.0
+               ELSE 
+                  IF( (SPDO(I,J).EQ. 0.0))THEN
+                     IF( (PSIO(I,J).GE. 0.0))THEN
+                        PSI= 180.0
+                     ELSE 
+                        PSI= 0.0
+                     ENDIF 
+                  ELSE 
+                     PSI=270.0 - RDTODG*ATAN2(PSIO(I,J),SPDO(I,J))
+                  ENDIF 
+               ENDIF 
+               PSI=MOD(MOD(PSI,360.0_ip_realwp_p)
+     $             +360.0_ip_realwp_p,360.0_ip_realwp_p)
+               SPDO(I,J)=SPD
+               PSIO(I,J)=PSI
+23028       CONTINUE 
+23026    CONTINUE 
+         RETURN
+      ENDIF 
+      WRITE(6, 600) GRTYP
+600   FORMAT('0',' Error bad grid (GDW2LLW) - GRTYP = ', A1)
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE GGGDINT(ZO,PX,PY,NPTS,AY,CY,Z,I1,I2,J1,J2)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+C*******
+C AUTEUR: Y.CHARTIER, DRPN
+C        FEVRIER 1991
+C
+C OBJET:  INTERPOLATION BI-CUBIQUE DE POINTS A PARTIR
+C        D'UNE GRILLE GAUSSIENNE.
+C*******
+      INTEGER (kind=ip_intwp_p) NPTS,I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) ZO(NPTS),PX(NPTS),PY(NPTS)
+      REAL(kind=ip_realwp_p) AY(J1:J2),CY(J1:J2,6)
+      REAL(kind=ip_realwp_p) Z(I1:I2,J1:J2)
+C
+C  NPTS   : NOMBRE DE POINTS A INTERPOLER
+C  I1:I2  : DIMENSION DE LA GRILLE SOURCE SELON X
+C  J1:J2  : DIMENSION DE LA GRILLE SOURCE SELON Y
+C  ZO     : VECTEUR DE SORTIE CONTENANT LES VALEURS INTERPOLEES
+C  PX     : VECTEUR CONTENANT LA POSITION X DES POINTS QUE L'ON
+C           VEUT INTERPOLER
+C  PY     : VECTEUR CONTENANT LA POSITION Y DES POINTS QUE L'ON
+C           VEUT INTERPOLER
+C  AY     : VECTEUR CONTENANT LA POS. DES POINTS SUR L'AXE DES Y.
+C  CY     : VECTEUR CONTENANT UNE TABLE DE DIFFERENCES SELON Y.
+C  Z      : VALEURS DE LA GRILLE SOURCE.
+C
+C***************************************************************************
+C
+C  *   *   *   *
+C
+C  *   *   *   *
+C        #        ==>   PT (X,Y)
+C  *  (=)  *   *  ==> = PT (I, J)
+C
+C  *   *   *   *
+C
+C
+C
+C  CY(I,1) = 1.0 / (X2-X1)
+C  CY(I,2) = 1.0 / (X3-X1)
+C  CY(I,3) = 1.0 / (X3-X2)
+C  CY(I,4) = 1.0 / (X4-X1)
+C  CY(I,5) = 1.0 / (X4-X2)
+C  CY(I,6) = 1.0 / (X4-X3)
+C
+C  STRUCTURE IDENTIQUE POUR CY(J,1..6)
+
+      INTEGER (kind=ip_intwp_p) I, J, M, N,STRIDE
+      REAL(kind=ip_realwp_p) X, X1, X2, X3, X4
+      REAL(kind=ip_realwp_p) B1, B2,  B3,  B4
+      REAL(kind=ip_realwp_p) B11, B12, B13, B14
+      REAL(kind=ip_realwp_p) Y,Y1,Y2,Y3,Y4
+      REAL(kind=ip_realwp_p) Y11, Y12, Y13, Y14
+      REAL(kind=ip_realwp_p) AY1, AY2, AY3, AY4
+      REAL(kind=ip_realwp_p) FA, FA2, FA3, FA4
+      REAL(kind=ip_realwp_p) A1,A2,A3,A4,C1,C2,C3,C4,C5,C6
+C  DEFINITION DES FONCTIONS IN-LINE
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      REAL(kind=ip_realwp_p) CUBIC, DX,DY,Z1,Z2,Z3,Z4
+      REAL(kind=ip_realwp_p) ZLIN, ZZ1, ZZ2, ZDX
+      CUBIC(Z1,Z2,Z3,Z4,DX)=((((Z4-Z1)*0.1666666666666 + 0.5*(Z2-Z3)
+     $)*DX + 0.5*(Z1+Z3)-Z2)*DX + Z3-0.1666666666666*Z4-0.5*Z2-0.
+     $3333333333333*Z1)*DX+Z2
+      ZLIN(ZZ1,ZZ2,ZDX) = ZZ1 + (ZZ2 - ZZ1) * ZDX
+      FA(A1,A2,A3,A4,X,X1,X2,X3)=A1+(X-X1)*(A2+(X-X2)*(A3+A4*(X-X3))
+     $)
+      FA2(C1,A1,A2)=C1*(A2-A1)
+      FA3(C1,C2,C3,A1,A2,A3)=C2*(C3*(A3-A2)-C1*(A2-A1))
+      FA4(C1,C2,C3,C4,C5,C6,A1,A2,A3,A4)=C4*(C5*(C6*(A4-A3)-C3*(A3-
+     $A2))   - C2*(C3*(A3-A2)-C1*(A2-A1)))
+      STRIDE = 1
+      IF( (ORDINT.EQ. CUBIQUE))THEN
+         DO 23002 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            DX = PX(N) - I
+            Y1=CUBIC(Z(I-1,J-1),Z(I  ,J-1),Z(I+1,J-1),Z(I+2,J-1),DX)
+            Y2=CUBIC(Z(I-1,J  ),Z(I  ,J  ),Z(I+1,J  ),Z(I+2,J  ),DX)
+            Y3=CUBIC(Z(I-1,J+1),Z(I  ,J+1),Z(I+1,J+1),Z(I+2,J+1),DX)
+            Y4=CUBIC(Z(I-1,J+2),Z(I  ,J+2),Z(I+1,J+2),Z(I+2,J+2),DX)
+            Y = AY(J) + (AY(J+1)-AY(J))*(PY(N)-J)
+C           INTERPOLATION FINALE SELON Y
+
+            AY1=AY(J-1)
+            AY2=AY(J)
+            AY3=AY(J+1)
+            AY4=AY(J+2)
+            Y11 = Y1
+            Y12 = FA2(CY(J,1),Y1,Y2)
+            Y13 = FA3(CY(J,1),CY(J,2),CY(J,3),Y1,Y2,Y3)
+            Y14 = FA4(CY(J,1),CY(J,2),CY(J,3),CY(J,4),CY(J,5),CY(J,6
+     $      ),Y1,Y2,Y3,Y4)
+            ZO(N) = FA(Y11,Y12,Y13,Y14,Y,AY1,AY2,AY3)
+23002    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. LINEAIR))THEN
+         DO 23006 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            DX = PX(N) - I
+            Y = AY(J) + (AY(J+1)-AY(J))*(PY(N)-J)
+            DY = (Y -AY(J))/(AY(J+1)-AY(J))
+            Y2=ZLIN(Z(I,J  ),Z(I+1,J  ),DX)
+            Y3=ZLIN(Z(I,J+1),Z(I+1,J+1),DX)
+            ZO(N)=ZLIN(Y2,Y3,DY)
+23006    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. VOISIN))THEN
+         DO 23010 N=1,NPTS
+            I = MIN(I2,MAX(I1,NINT(PX(N))))
+            J = MIN(J2,MAX(J1,NINT(PY(N))))
+            ZO(N) = Z(I,J)
+23010    CONTINUE 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE GGLL2GD(X,Y,XLAT,XLON,NPTS,NI,NJ,HEM,LROOTS)
+C* -------------------------------------------------------------------
+C* S/R GGLL2GD - COMPUTES THE GRID CO-ORDINATES OF A POINT ON
+C                A GAUSSIAN GRID
+C* -------------------------------------------------------------------
+      USE mod_kinds_oasis
+C* -------------------------------------------------------------------
+      IMPLICIT NONE
+C* --------------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      INTEGER (kind=ip_intwp_p) NPTS, NI, NJ
+      REAL(kind=ip_realwp_p) X(NPTS), Y(NPTS), XLAT(NPTS), XLON(NPTS)
+      REAL(kind=ip_realwp_p) LROOTS(NJ)
+      REAL(kind=ip_realwp_p) ABS,DEL,EPSPHI
+      INTEGER (kind=ip_intwp_p) HEM
+      INTEGER (kind=ip_intwp_p) I,J
+      INTEGER (kind=ip_intwp_p) GUESS
+      INTEGER (kind=ip_intwp_p) NJHEM
+      REAL(kind=ip_realwp_p) TMPLAT, DELLAT, DELLON, XLAT0, XLON0
+      IF( (HEM.EQ. GLOBAL))THEN
+         NJHEM = NJ / 2
+      ELSE 
+         NJHEM = NJ
+      ENDIF 
+      DELLON = 360.0 / REAL(NI,kind=ip_realwp_p)
+      XLON0 = 0.0
+      DELLAT = 90.0 / REAL(NJHEM,kind=ip_realwp_p)
+      XLAT0 = DELLAT * 0.5
+CVDIR NOVECTOR
+
+      DO 23002 I = 1, NPTS
+         X(I) = (XLON(I) - XLON0)/DELLON + 1.0
+         TMPLAT = XLAT(I)
+         IF( (TMPLAT.LT. 0))THEN
+            TMPLAT = -TMPLAT
+         ENDIF 
+         IF( (TMPLAT.GT. LROOTS(NJHEM)))THEN
+            Y(I)=NJHEM+0.5*(TMPLAT-LROOTS(NJHEM))/(90.0-LROOTS(NJHEM
+     $      ))
+         ELSE 
+            IF( (TMPLAT.LT. LROOTS(1)))THEN
+               Y(I)=0.5+(0.5*TMPLAT/LROOTS(1))
+            ELSE 
+               GUESS=INT((TMPLAT-XLAT0)/DELLAT + 1.0)
+23010          IF((LROOTS(GUESS+1).LT.TMPLAT))THEN
+                  GUESS = GUESS+1
+                  GOTO 23010
+               ENDIF 
+23012          IF((LROOTS(GUESS).GE.TMPLAT))THEN
+                  GUESS = GUESS-1
+                  GOTO 23012
+               ENDIF 
+               Y(I)=GUESS+(TMPLAT-LROOTS(GUESS))/(LROOTS(GUESS+1)-
+     $            LROOTS(GUESS))
+            ENDIF 
+         ENDIF 
+         IF( (HEM.EQ. GLOBAL))THEN
+            IF( (0.EQ. MOD(NJ, 2)))THEN
+               IF( (XLAT(I).GE. 0.0))THEN
+                  Y(I) = Y(I) + NJHEM
+               ELSE 
+                  Y(I) = NJHEM - Y(I) + 1
+               ENDIF 
+            ELSE 
+               IF( (XLAT(I).GE. 0.0))THEN
+                  Y(I) = Y(I) + NJHEM + 1
+               ELSE 
+                  Y(I) = NJHEM - Y(I) + 1
+               ENDIF 
+            ENDIF 
+         ENDIF 
+         IF( (HEM.EQ. NORD))THEN
+            IF( (XLAT(I).LT. 0.0))THEN
+               Y(I) = -Y(I) + 1
+            ENDIF 
+         ENDIF 
+         IF( (HEM.EQ. SUD))THEN
+            IF( (XLAT(I).GE. 0.0))THEN
+               Y(I) = Y(I) + NJ
+            ELSE 
+               Y(I) = NJ - Y(I) + 1.0
+            ENDIF 
+         ENDIF 
+23002 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      BLOCK DATA QQQCOMBLK
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+C* ----------------------------------------------------------------------
+C* COMMON QQQCOM1
+C
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+      DATA XGDPTR, YGDPTR, ZPTR   /   0,   0,   0  /
+      DATA AXPTR, AYPTR, CXPTR, CYPTR   /   0,   0,   0,   0 /
+      DATA NPOLPTR,SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX   /   0,
+     $   0,   0,   0,   0,   0  /
+      DATA PTPOLN, PTPOLS / .FALSE., .FALSE. /
+C
+C-- COMMON QQQCOM2, QQQCOM3
+C-
+
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      INTEGER (kind=ip_intwp_p) LSTLILJ, LSTNI, LSTNJ, LSTXOR
+      INTEGER (kind=ip_intwp_p) LSTIG1, LSTIG2, LSTIG3, LSTIG4
+      COMMON /QQQCOM2/ I1,I2,J1,J2,LSTLILJ,LSTNI,LSTNJ,LSTIG1,LSTIG2
+     $,LSTIG3,LSTIG4,LSTXOR
+      CHARACTER*1 LSTGTYP
+      COMMON /QQQCOM3/ LSTGTYP
+      DATA LSTLILJ, LSTNI, LSTNJ, LSTIG1, LSTIG2, LSTIG3, LSTIG4   /
+     $   0,   0,   0,   0,   0,   0,   0 /
+      DATA LSTXOR, LSTGTYP   /   0,   ' ' /
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE IGSCINT(ZO,LI,LJ,XLAT,XLON,ZI,NI,NJ,GRTYP,GRREF,IG1
+     $,IG2,IG3,IG4,SYM,AX,AY,VECFLG)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LI,LJ,NI,NJ,IG1,IG2,IG3,IG4,BIDON
+      REAL(kind=ip_realwp_p) ZO(LI,LJ),XLAT(LI,LJ),XLON(LI,LJ)
+      REAL(kind=ip_realwp_p) ZI(NI,NJ),AX(NI),AY(NJ)
+      LOGICAL SYM
+      CHARACTER*1 GRTYP, GRREF
+      LOGICAL QQQCMP
+      EXTERNAL QQQCMP, RGOPTI
+      EXTERNAL RGFREE, QQQCHK, QQQALOC, QQQKEEP, LL2RGD, LL2IGD
+      EXTERNAL XPNCOF, XPNGD, NWTNCOF, IRGDINT, RGDINT
+      EXTERNAL XPNAXEZ,XPNAXEG,GGGDINT,QQQGLAT,QQQXTRAP,POLRINT
+      EXTERNAL XPNAXEY
+C
+CDEFINITION DES VARIABLES LOCALES
+C
+C-- COMMON QQQCOM1
+C--
+C
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C----------------------
+C-- COMMON QQQCOM2
+C-
+
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      INTEGER (kind=ip_intwp_p) LSTLILJ, LSTNI, LSTNJ, LSTXOR
+      INTEGER (kind=ip_intwp_p) LSTIG1, LSTIG2, LSTIG3, LSTIG4
+      COMMON /QQQCOM2/ I1,I2,J1,J2,LSTLILJ,LSTNI,LSTNJ,LSTIG1,LSTIG2
+     $,LSTIG3,LSTIG4,LSTXOR
+C-
+C------------
+C* COMMON QQQCOM3
+C
+
+      CHARACTER*1 LSTGTYP
+      COMMON /QQQCOM3/ LSTGTYP
+C------------
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      EXTERNAL QQQCOMBLK
+      LOGICAL OK
+      INTEGER (kind=ip_intwp_p) XORSUM
+      LOGICAL VECTEUR
+C
+C* Test if field is scalar or vector
+C* ---------------------------------
+C
+      CHARACTER*6 VECFLG
+      IF (VECFLG .EQ. 'SCALAR') THEN
+          VECTEUR = .FALSE.
+        ELSEIF (VECFLG .EQ. 'VECTOR') THEN
+          VECTEUR = .TRUE.
+        ELSE
+          WRITE(6,*) ' WARNING !!! Wrong value for VECFLG '
+          WRITE(6,*) ' WE STOP IN igscint                 '
+          WRITE(6,*) ' '
+          STOP
+      ENDIF
+C*----------------------
+C
+CVERIFICATION DU TYPE DE GRILLE
+C
+
+      IF( (GRTYP.EQ. 'Z' .OR. GRTYP .EQ. 'Y')
+     $    .AND. (GRREF.EQ. 'N'.OR. GRREF.EQ. 'S'.OR.
+     $    GRREF.EQ. 'L')) THEN
+         GOTO 10
+      ELSE 
+         GOTO 101
+      ENDIF 
+      ENTRY IGVINT(ZO,LI,LJ,XLAT,XLON,ZI,NI,NJ,GRTYP,GRREF,IG1,IG2,
+     $IG3,IG4,SYM,AX,AY)
+      VECTEUR = .TRUE.
+      IF( (GRTYP.EQ.'Z' .OR. GRTYP .EQ. 'Y')
+     $    .AND. (GRREF.EQ. 'N'.OR. GRREF.EQ. 'S'.OR.
+     $    GRREF.EQ. 'L')) THEN
+         GOTO 10
+      ELSE 
+         GOTO 101
+      ENDIF 
+101   CONTINUE
+      IF( GRTYP .NE. 'Z' .OR. GRTYP .NE. 'Y')THEN
+         WRITE(6,*) 'Error, bad grid type (GRTYP)(IGSCINT)'
+         WRITE(6,*) '''GRTYP'' should be equal to ''Z'' or ''Y'''
+      ELSE 
+         WRITE(6,*) 
+     $    'Error, bad grid type (GRREF)(IGSCINT)'
+         WRITE(6,*)
+     $    '''GRREF'' should be equal to ''N'', ''S'' or ''L'''
+      ENDIF 
+      RETURN
+      ENTRY RGVINT(ZO,LI,LJ,XLAT,XLON,ZI,NI,NJ,GRTYP,IG1,IG2,IG3,IG4
+     $,SYM)
+      VECTEUR = .TRUE.
+      GOTO 3
+      ENTRY RGSCINT(ZO,LI,LJ,XLAT,XLON,ZI,NI,NJ,GRTYP,IG1,IG2,IG3,
+     $IG4,SYM,VECFLG)
+C
+C* Test if field is scalar or vector
+C* ---------------------------------
+C
+      IF (VECFLG .EQ. 'SCALAR') THEN
+          VECTEUR = .FALSE.
+        ELSEIF (VECFLG .EQ. 'VECTOR') THEN
+          VECTEUR = .TRUE.
+        ELSE
+          WRITE(6,*) ' WARNING !!! Wrong value for VECFLG '
+          WRITE(6,*) ' WE STOP IN igscint                 '
+          WRITE(6,*) ' '
+          STOP
+      ENDIF
+C*
+3     CONTINUE
+      IF( (GRTYP.EQ.'A'.OR.GRTYP.EQ.'B'.OR.GRTYP.EQ.'L'.OR.GRTYP.EQ.
+     $'N'.OR.GRTYP.EQ.'S'   .OR.GRTYP.EQ.'G'))THEN
+         GOTO 10
+      ENDIF 
+      WRITE (6,200)
+200   FORMAT('0','Error bad grid type (GRTYP)(RGSCINT)')
+      RETURN
+10    CALL RGOPTI('INTERP', BIDON, .FALSE.)
+      OK = QQQCMP(XLAT,XLON,LI*LJ,NI,NJ,GRTYP,IG1,IG2,IG3,IG4,XORSUM
+     $)
+      IF( (.NOT.OK))THEN
+         CALL XPNCOF(I1,I2,J1,J2,NI,NJ,GRTYP,GRREF,IG1,IG1,IG3,IG4,
+     $   SYM,AX,AY)
+         CALL RGFREE
+         CALL QQQALOC(XLAT, XLON, LI, LJ, I1, I2, J1, J2)
+         CALL QQQKEEP(LI*LJ,NI,NJ,GRTYP,IG1,IG2,IG3,IG4,XORSUM)
+         CALL QQQCHK(XLAT, XLON, LI*LJ)
+         IF( GRTYP.EQ. 'Z' .OR. GRTYP.EQ. 'Y')THEN
+         IF( GRTYP.EQ. 'Z') CALL XPNAXEZ(AXTMP(AXPTR),AYTMP(AYPTR),
+     $           I1,I2,J1,J2,AX,AY,NI,NJ)
+         IF( GRTYP.EQ. 'Y') CALL XPNAXEY(AXTMP(AXPTR),AYTMP(AYPTR),
+     $           I1,I2,J1,J2,AX,AY,NI,NJ)
+            CALL NWTNCOF(CXTMP(CXPTR),CYTMP(CYPTR),AXTMP(AXPTR),
+     $      AYTMP(AYPTR),I1,I2,J1,J2)
+            CALL LL2IGD(XGD(XGDPTR),YGD(YGDPTR),XLAT,XLON,LI*LJ,NI,
+     $      NJ,GRTYP,GRREF,IG1,IG2,IG3,IG4,SYM,AX,AY)
+         ELSE 
+            IF( (GRTYP.EQ. 'G'))THEN
+               CALL QQQGLAT(NJ,IG1)
+               CALL XPNAXEG(AXTMP(AXPTR),AYTMP(AYPTR),I1,I2,J1,J2,NI
+     $         ,NJ,IG1)
+               CALL NWTNCOF(CXTMP(CXPTR),CYTMP(CYPTR),AXTMP(AXPTR),
+     $         AYTMP(AYPTR),I1,I2,J1,J2)
+            ENDIF 
+            CALL LL2RGD(XGD(XGDPTR),YGD(YGDPTR),XLAT,XLON,LI*LJ,NI,
+     $      NJ,GRTYP,IG1,IG2,IG3,IG4,SYM)
+         ENDIF 
+      ENDIF 
+      CALL XPNGD(ZTMP(ZPTR),I1,I2,J1,J2,ZI,NI,NJ,GRTYP,IG1,IG2,IG3,
+     $IG4,SYM,VECTEUR)
+      IF( (GRTYP.EQ. 'Z' .OR. GRTYP .EQ. 'Y'))THEN
+         CALL IRGDINT(ZO,XGD(XGDPTR),YGD(YGDPTR),LI*LJ,AXTMP(AXPTR),
+     $   AYTMP(AYPTR),CXTMP(CXPTR),CYTMP(CYPTR),ZTMP(ZPTR),I1,I2,J1,
+     $   J2)
+      ENDIF 
+      IF( (GRTYP.EQ. 'G'))THEN
+         CALL GGGDINT(ZO,XGD(XGDPTR),YGD(YGDPTR),LI*LJ,AYTMP(AYPTR),
+     $   CYTMP(CYPTR),ZTMP(ZPTR),I1,I2,J1,J2)
+      ENDIF 
+      IF( (GRTYP.NE. 'G'.AND. GRTYP.NE. 'Z' 
+     $    .AND. GRTYP .NE. 'Y'))THEN
+         CALL RGDINT(ZO,XGD(XGDPTR),YGD(YGDPTR),LI*LJ,ZTMP(ZPTR),I1,
+     $   I2,J1,J2)
+      ENDIF 
+      IF( (GRTYP.EQ. 'L'.OR. GRTYP.EQ. 'N'.OR. GRTYP.EQ. 'S'.OR.
+     $ GRTYP.EQ. 'Z' .OR. GRTYP .EQ. 'Y'))THEN
+         CALL QQQXTRAP(ZO,XGD(XGDPTR),YGD(YGDPTR),LI*LJ,ZTMP(ZPTR),
+     $   I1,I2,J1,J2)
+      ENDIF 
+      IF( (PTPOLN.OR. PTPOLS))THEN
+         CALL POLRINT(ZO,XLAT,XLON,LI*LJ,ZTMP(ZPTR),NI,NJ,I1,I2,J1,
+     $   J2,GRTYP,IG1,IG2,IG3,IG4,VECTEUR)
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE IGUVINT(SPDO,PSIO,LI,LJ,XLAT,XLON,UI,VI,NI,NJ,GRTYP
+     $,GRREF,IG1,IG2,IG3,IG4,SWS,AX,AY)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LI,LJ,NI,NJ,IG1,IG2,IG3,IG4,BIDON
+      REAL(kind=ip_realwp_p) SPDO(LI,LJ),PSIO(LI,LJ),XLAT(LI,LJ),
+     $     XLON(LI,LJ)
+      REAL(kind=ip_realwp_p) UI(NI,NJ),VI(NI,NJ),AX(NI),AY(NJ)
+      LOGICAL SWS
+      CHARACTER*1 GRTYP, GRREF
+      EXTERNAL GDW2LLW,IGSCINT,RGVINT,MODULE,RGOPTI,IGVINT
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+C* -------------------------------------------------------------------
+C
+CVERIFICATION DU TYPE DE GRILLE
+C
+
+      CALL RGOPTI('INTERP', BIDON, .FALSE.)
+      IF( (GRTYP.EQ.'Z' .OR. GRTYP .EQ. 'Y')
+     $    .AND. (GRREF.EQ. 'N'.OR. GRREF.EQ. 'S'.OR.
+     $ GRREF.EQ. 'L')) THEN
+         CALL IGVINT(SPDO,LI,LJ,XLAT,XLON,UI,NI,NJ,GRTYP,GRREF,IG1,
+     $   IG2,IG3,IG4,.TRUE.,AX,AY)
+         CALL IGVINT(PSIO,LI,LJ,XLAT,XLON,VI,NI,NJ,GRTYP,GRREF,IG1,
+     $   IG2,IG3,IG4,.FALSE.,AX,AY)
+         IF( (SWS))THEN
+            CALL GDW2LLW(SPDO,PSIO,XLON,LI,LJ,GRREF,IG1,IG2,IG3,IG4)
+         ELSE 
+            CALL MODULE(SPDO,PSIO,LI,LJ)
+         ENDIF 
+      ELSE 
+         IF( (GRTYP.NE. 'Z' .AND. GRTYP .NE. 'Y'))THEN
+            WRITE(6,*)
+     $       'Error, Bad grid type (GRTYP)(IGSCINT)'
+            WRITE(6,*) 
+     $          '''GRTYP'' should be equal to ''Z'' or ''Y'''
+         ELSE 
+            WRITE(6,*)
+     $ 'Error, Bad reference grid type(GRREF)(IGSCINT)'
+            WRITE(6,*)
+     $       '''GRREF'' should be equal to ''N'', ''S'' or ''L'''
+         ENDIF 
+      ENDIF 
+      RETURN
+      ENTRY RGUVINT(SPDO,PSIO,LI,LJ,XLAT,XLON,UI,VI,NI,NJ,GRTYP,IG1,
+     $IG2,IG3,IG4,SWS)
+      CALL RGOPTI('INTERP', BIDON, .FALSE.)
+      IF( (GRTYP.EQ.'A'.OR.GRTYP.EQ.'B'.OR.GRTYP.EQ.'L'.OR.GRTYP.EQ.
+     $'N'.OR.GRTYP.EQ.'S'   .OR.GRTYP.EQ.'G'))THEN
+         CALL RGVINT(SPDO,LI,LJ,XLAT,XLON,UI,NI,NJ,GRTYP,IG1,IG2,IG3
+     $   ,IG4,.TRUE.)
+         CALL RGVINT(PSIO,LI,LJ,XLAT,XLON,VI,NI,NJ,GRTYP,IG1,IG2,IG3
+     $   ,IG4,.FALSE.)
+         IF( (SWS))THEN
+            CALL GDW2LLW(SPDO,PSIO,XLON,LI,LJ,GRTYP,IG1,IG2,IG3,IG4)
+         ELSE 
+            CALL MODULE(SPDO,PSIO,LI,LJ)
+         ENDIF 
+      ELSE 
+         WRITE (6,200)
+200      FORMAT('0','Error bad grid type (GRTYP)(RGSCINT)')
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE IRGDINT(ZO,PX,PY,NPTS,AX,AY,CX,CY,Z,I1,I2,J1,J2)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+C*******
+C AUTEUR: Y.CHARTIER, DRPN
+C        FEVRIER 1991
+C
+C OBJET:  INTERPOLATION BI-CUBIQUE DE POINTS A PARTIR
+C        D'UNE GRILLE SOURCE IRREGULIERE.
+C*******
+      INTEGER (kind=ip_intwp_p) NPTS,I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) ZO(NPTS),PX(NPTS),PY(NPTS)
+      REAL(kind=ip_realwp_p) FA, FA2, FA3, FA4
+      REAL(kind=ip_realwp_p) AX(I1:I2),AY(J1:J2),CX(I1:I2,6)
+      REAL(kind=ip_realwp_p) CY(J1:J2,6)
+      REAL(kind=ip_realwp_p) Z(I1:I2,J1:J2)
+C
+C  NPTS   : NOMBRE DE POINTS A INTERPOLER
+C  I1:I2  : DIMENSION DE LA GRILLE SOURCE SELON X
+C  J1:J2  : DIMENSION DE LA GRILLE SOURCE SELON Y
+C  ZO     : VECTEUR DE SORTIE CONTENANT LES VALEURS INTERPOLEES
+C  PX     : VECTEUR CONTENANT LA POSITION X DES POINTS QUE L'ON
+C           VEUT INTERPOLER
+C  PY     : VECTEUR CONTENANT LA POSITION Y DES POINTS QUE L'ON
+C           VEUT INTERPOLER
+C  AX     : VECTEUR CONTENANT LA POS. DES POINTS SUR L'AXE DES X.
+C  AY     : VECTEUR CONTENANT LA POS. DES POINTS SUR L'AXE DES Y.
+C  CX     : VECTEUR CONTENANT UNE TABLE DE DIFFERENCES SELON X.
+C  CY     : VECTEUR CONTENANT UNE TABLE DE DIFFERENCES SELON Y.
+C  Z      : VALEURS DE LA GRILLE SOURCE.
+C
+C***************************************************************************
+C
+C  *   *   *   *
+C
+C  *   *   *   *
+C        #        ==>   PT (X,Y)
+C  *  (=)  *   *  ==> = PT (I, J)
+C
+C  *   *   *   *
+C
+C
+C
+C  CX(I,1) = 1.0 / (X2-X1)
+C  CX(I,2) = 1.0 / (X3-X1)
+C  CX(I,3) = 1.0 / (X3-X2)
+C  CX(I,4) = 1.0 / (X4-X1)
+C  CX(I,5) = 1.0 / (X4-X2)
+C  CX(I,6) = 1.0 / (X4-X3)
+C
+C  STRUCTURE IDENTIQUE POUR CY(J,1..6)
+
+      REAL(kind=ip_realwp_p) A11,A12,A13,A14,A21,A22,A23,A24
+      REAL(kind=ip_realwp_p) A31,A32,A33,A34,A41,A42,A43,A44
+      REAL(kind=ip_realwp_p) B1,B2,B3,B4,B11,B12,B13,B14
+      REAL(kind=ip_realwp_p) X1,X2,X3,X4,Y1,Y2,Y3,Y4
+      INTEGER (kind=ip_intwp_p) I, J, N
+      REAL(kind=ip_realwp_p) A1,A2,A3,A4,X,Y,C1,C2,C3,C4,C5,C6
+C  DEFINITION DES FONCTIONS IN-LINE
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      REAL(kind=ip_realwp_p) CUBIC, DX,DY,Z1,Z2,Z3,Z4
+      REAL(kind=ip_realwp_p) ZLIN, ZZ1, ZZ2, ZDX
+      CUBIC(Z1,Z2,Z3,Z4,DX)=((((Z4-Z1)*0.1666666666666 + 0.5*(Z2-Z3)
+     $)*DX + 0.5*(Z1+Z3)-Z2)*DX + Z3-0.1666666666666*Z4-0.5*Z2-0.
+     $3333333333333*Z1)*DX+Z2
+      ZLIN(ZZ1,ZZ2,ZDX) = ZZ1 + (ZZ2 - ZZ1) * ZDX
+      FA(A1,A2,A3,A4,X,X1,X2,X3)=A1+(X-X1)*(A2+(X-X2)*(A3+A4*(X-X3))
+     $)
+      FA2(C1,A1,A2)=C1*(A2-A1)
+      FA3(C1,C2,C3,A1,A2,A3)=C2*(C3*(A3-A2)-C1*(A2-A1))
+      FA4(C1,C2,C3,C4,C5,C6,A1,A2,A3,A4)=C4*(C5*(C6*(A4-A3)-C3*(A3-
+     $A2))   - C2*(C3*(A3-A2)-C1*(A2-A1)))
+      IF( (ORDINT.EQ. CUBIQUE))THEN
+         DO 23002 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            X = AX(I) + (AX(I+1)-AX(I))*(PX(N)-I)
+            Y = AY(J) + (AY(J+1)-AY(J))*(PY(N)-J)
+            X1=AX(I-1)
+            X2=AX(I)
+            X3=AX(I+1)
+            X4=AX(I+2)
+            Y1=AY(J-1)
+            Y2=AY(J)
+            Y3=AY(J+1)
+            Y4=AY(J+2)
+C        INTERPOLATION 1ERE RANGEE SELON X
+
+            Z1=Z(I-1,J-1)
+            Z2=Z(I  ,J-1)
+            Z3=Z(I+1,J-1)
+            Z4=Z(I+2,J-1)
+            A11 = Z1
+            A12 = FA2(CX(I,1),Z1,Z2)
+            A13 = FA3(CX(I,1),CX(I,2),CX(I,3),Z1,Z2,Z3)
+            A14 = FA4(CX(I,1),CX(I,2),CX(I,3),CX(I,4),CX(I,5),CX(I,6
+     $      ),Z1,Z2,Z3,Z4)
+            B1  = FA(A11,A12,A13,A14,X,X1,X2,X3)
+C        INTERPOLATION 2EME RANGEE SELON X
+
+            Z1=Z(I-1,J)
+            Z2=Z(I  ,J)
+            Z3=Z(I+1,J)
+            Z4=Z(I+2,J)
+            A21 = Z1
+            A22 = FA2(CX(I,1),Z1,Z2)
+            A23 = FA3(CX(I,1),CX(I,2),CX(I,3),Z1,Z2,Z3)
+            A24 = FA4(CX(I,1),CX(I,2),CX(I,3),CX(I,4),CX(I,5),CX(I,6
+     $      ),Z1,Z2,Z3,Z4)
+            B2  = FA(A21,A22,A23,A24,X,X1,X2,X3)
+C     INTERPOLATION 3EME RANGEE SELON X
+
+            Z1=Z(I-1,J+1)
+            Z2=Z(I  ,J+1)
+            Z3=Z(I+1,J+1)
+            Z4=Z(I+2,J+1)
+            A31 = Z1
+            A32 = FA2(CX(I,1),Z1,Z2)
+            A33 = FA3(CX(I,1),CX(I,2),CX(I,3),Z1,Z2,Z3)
+            A34 = FA4(CX(I,1),CX(I,2),CX(I,3),CX(I,4),CX(I,5),CX(I,6
+     $      ),Z1,Z2,Z3,Z4)
+            B3  = FA(A31,A32,A33,A34,X,X1,X2,X3)
+C        INTERPOLATION 4EME RANGEE SELON X
+
+            Z1=Z(I-1,J+2)
+            Z2=Z(I  ,J+2)
+            Z3=Z(I+1,J+2)
+            Z4=Z(I+2,J+2)
+            A41 = Z1
+            A42 = FA2(CX(I,1),Z1,Z2)
+            A43 = FA3(CX(I,1),CX(I,2),CX(I,3),Z1,Z2,Z3)
+            A44 = FA4(CX(I,1),CX(I,2),CX(I,3),CX(I,4),CX(I,5),CX(I,6
+     $      ),Z1,Z2,Z3,Z4)
+            B4  = FA(A41,A42,A43,A44,X,X1,X2,X3)
+C        INTERPOLATION FINALE SELON Y
+
+            B11 = B1
+            B12 = FA2(CY(J,1),B1,B2)
+            B13 = FA3(CY(J,1),CY(J,2),CY(J,3),B1,B2,B3)
+            B14 = FA4(CY(J,1),CY(J,2),CY(J,3),CY(J,4),CY(J,5),CY(J,6
+     $      ),B1,B2,B3,B4)
+            ZO(N) = FA(B11,B12,B13,B14,Y,Y1,Y2,Y3)
+23002    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. LINEAIR))THEN
+         DO 23006 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            X = AX(I) + (AX(I+1)-AX(I))*(PX(N)-I)
+            Y = AY(J) + (AY(J+1)-AY(J))*(PY(N)-J)
+            DX = (X - AX(I))/(AX(I+1)-AX(I))
+            DY = (Y - AY(J))/(AY(J+1)-AY(J))
+            Y1 = ZLIN(Z(I,J),Z(I+1,J),DX)
+            Y2 = ZLIN(Z(I,J+1),Z(I+1,J+1),DX)
+            ZO(N) = ZLIN(Y1,Y2,DY)
+23006    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. VOISIN))THEN
+         DO 23010 N=1,NPTS
+            I = MIN(I2,MAX(I1,NINT(PX(N))))
+            J = MIN(J2,MAX(J1,NINT(PY(N))))
+            ZO(N) = Z(I,J)
+23010    CONTINUE 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE LL2IGD(PX,PY,XLAT,XLON,NPTS,NI,NJ,GRTYP,GRREF,IG1,
+     $IG2,IG3,IG4,SYM,AX,AY)
+C* ----------------------------------------------------------------------
+C**S/R LL2IGD - CONVERSION DE COORDONNEES LAT-LON A PTS DE GRILLE
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      EXTERNAL CIGAXG,VXYFLL,LLLL2GD,PERMUT,CHKXTRAP
+      INTEGER (kind=ip_intwp_p) I, NPTS, NI, NJ
+      REAL(kind=ip_realwp_p) PX(NPTS),PY(NPTS),XLAT(NPTS),XLON(NPTS)
+      CHARACTER*1 GRTYP, GRREF
+      INTEGER (kind=ip_intwp_p) IG1,IG2,IG3,IG4
+      LOGICAL SYM
+      REAL(kind=ip_realwp_p) AX(NI), AY(NJ)
+      REAL(kind=ip_realwp_p) PI,PJ,DGRW,D60,TMP
+      REAL(kind=ip_realwp_p) DLAT, DLON, XLAT0, XLON0
+      INTEGER (kind=ip_intwp_p) INDX, INDY
+      INTEGER (kind=ip_intwp_p) CHERCHE, FINDLON
+      EXTERNAL CHERCHE, FINDLON 
+      IF( (GRREF.EQ. 'N'.OR. GRREF.EQ. 'S'.OR. GRREF.EQ. 'L')
+     $)THEN
+         IF( (GRREF.EQ. 'N'))THEN
+            CALL CIGAXG(GRREF,  PI, PJ, D60, DGRW, IG1, IG2, IG3,
+     $       IG4)
+            CALL VXYFLL(PX, PY, XLAT, XLON, NPTS, D60,DGRW,PI,PJ,1)
+         ELSE 
+            IF( (GRREF.EQ. 'S'))THEN
+               CALL CIGAXG(GRREF,  PI, PJ, D60, DGRW, IG1, IG2, IG3,
+     $          IG4)
+               CALL VXYFLL(PX, PY, XLAT, XLON, NPTS, D60,DGRW,PI,PJ,
+     $         2)
+            ELSE 
+               CALL CIGAXG(GRREF, XLAT0, XLON0, DLAT, DLON, IG1, IG2
+     $         , IG3, IG4)
+               CALL LLLL2GD(PX, PY, XLAT, XLON, NPTS, XLAT0, XLON0,
+     $          DLAT, DLON)
+            ENDIF 
+         ENDIF 
+         DO 23006 I=1,NPTS
+            INDX = FINDLON(PX(I), AX, NI, TMP)
+            INDY = CHERCHE(PY(I), AY, NJ)
+            IF( (INDX.GE. NI))THEN
+               INDX = NI - 1
+            ENDIF 
+            IF( (INDY.GE. NJ))THEN
+               INDY = NJ - 1
+            ENDIF 
+            PX(I)=REAL(INDX,kind=ip_realwp_p)+
+     $          (TMP-AX(INDX))/(AX(INDX+1)-AX(INDX))
+            PY(I) = REAL(INDY,kind=ip_realwp_p) 
+     $          + (PY(I) - AY(INDY))/(AY(INDY+1)-AY(INDY))
+23006    CONTINUE 
+         CALL CHKXTRAP(PX, PY, NPTS, NI, NJ)
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE LL2RGD(PX,PY,XLAT,XLON,NPTS,NI,NJ,GRTYP,IG1,IG2,IG3
+     $,IG4,SYM)
+C* -----------------------------------------------------------------
+C* S/R LL2RGD - CONVERSION DE COORDONNEES LAT-LON A PTS DE GRILLE
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+C-- COMMON GAUSSGD
+C      REAL(kind=ip_realwp_p) ROOTS(1),LROOTS(1)
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ROOTS,LROOTS
+      INTEGER (kind=ip_intwp_p) IROOTS, ILROOTS
+      COMMON /GAUSSGD/ ROOTS,LROOTS,IROOTS,ILROOTS
+C----------------------
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      EXTERNAL CIGAXG,VXYFLL,LLLL2GD,PERMUT
+      EXTERNAL QQQGLAT,GGLL2GD,CHKXTRAP
+      INTEGER (kind=ip_intwp_p) NPTS, NI, NJ
+      REAL(kind=ip_realwp_p) PX(NPTS),PY(NPTS),XLAT(NPTS),XLON(NPTS)
+      CHARACTER*1 GRTYP
+      INTEGER (kind=ip_intwp_p) IG1,IG2,IG3,IG4
+      LOGICAL SYM
+      REAL(kind=ip_realwp_p) PI,PJ,DGRW,D60
+      REAL(kind=ip_realwp_p) DELLAT, DELLON, XLAT0, XLON0
+      INTEGER (kind=ip_intwp_p) I,J
+      IF( (GRTYP.EQ.'N'))THEN
+         CALL CIGAXG(GRTYP,PI,PJ,D60,DGRW,IG1,IG2,IG3,IG4)
+         CALL VXYFLL(PX,PY,XLAT,XLON,NPTS,D60,DGRW,PI,PJ,NORD)
+         CALL CHKXTRAP(PX,PY,NPTS,NI,NJ)
+      ENDIF 
+      IF( (GRTYP.EQ.'S'))THEN
+         CALL CIGAXG(GRTYP,PI,PJ,D60,DGRW,IG1,IG2,IG3,IG4)
+         CALL VXYFLL(PX,PY,XLAT,XLON,NPTS,D60,DGRW,PI,PJ,SUD)
+         CALL CHKXTRAP(PX,PY,NPTS,NI,NJ)
+      ENDIF 
+      IF( (GRTYP.EQ.'A'))THEN
+         DELLON = 360.0 / REAL(NI,ip_realwp_p)
+         XLON0 = 0.0
+         IF( (IG1.EQ. GLOBAL))THEN
+            DELLAT = 180.0 / REAL(NJ,ip_realwp_p)
+            XLAT0 = -90.0 + DELLAT * 0.5
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            DELLAT = 90.0 / REAL(NJ,ip_realwp_p)
+            XLAT0 =  DELLAT * 0.5
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            DELLAT = 90.0 / REAL(NJ,ip_realwp_p)
+            XLAT0 = -90.0 + DELLAT * 0.5
+         ENDIF 
+         FLGXTRAP = .FALSE.
+         CALL LLLL2GD(PX,PY,XLAT,XLON,NPTS,XLAT0, XLON0, DELLAT,
+     $    DELLON)
+      ENDIF 
+      IF( (GRTYP.EQ.'B'))THEN
+         DELLON = 360.0 / REAL(NI-1,ip_realwp_p)
+         XLON0 = 0.0
+         IF( (IG1.EQ. GLOBAL))THEN
+            DELLAT = 180.0 / REAL(NJ-1,ip_realwp_p)
+            XLAT0 = -90.0
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            DELLAT = 90.0 / REAL(NJ-1,ip_realwp_p)
+            XLAT0 =  0.0
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            DELLAT = 90.0 / REAL(NJ-1,ip_realwp_p)
+            XLAT0 = -90.0
+         ENDIF 
+         FLGXTRAP = .FALSE.
+         CALL LLLL2GD(PX,PY,XLAT,XLON,NPTS,XLAT0, XLON0, DELLAT,
+     $    DELLON)
+      ENDIF 
+      IF( (GRTYP.EQ. 'G'))THEN
+         FLGXTRAP = .FALSE.
+         CALL GGLL2GD(PX,PY,XLAT,XLON,NPTS,NI,NJ,IG1,LROOTS(ILROOTS)
+     $   )
+      ENDIF 
+      IF( (GRTYP.EQ. 'L'))THEN
+         CALL CIGAXG(GRTYP,XLAT0,XLON0,DELLAT,DELLON,IG1,IG2,IG3,IG4
+     $   )
+         DO 23024 I=1,NPTS
+            IF( (XLON(I).LT. XLON0))THEN
+               XLON(I) = XLON(I) + 360.0
+            ENDIF 
+            IF( (XLON(I).GT. (XLON0 + NI*DELLON)))THEN
+               XLON(I) = XLON(I) - 360.0
+            ENDIF 
+23024    CONTINUE 
+         CALL LLLL2GD(PX,PY,XLAT,XLON,NPTS,XLAT0, XLON0, DELLAT,
+     $    DELLON)
+         CALL CHKXTRAP(PX,PY,NPTS,NI,NJ)
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE LLLL2GD(X,Y,DLAT,DLON,NPTS,XLAT0,XLON0, DELLAT,
+     $ DELLON)
+C* ----------------------------------------------------------------------
+C* S/R LLLL2GD - COMPUTES THE GRID CO-ORDINATES OF A POINT
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) NPTS
+      REAL(kind=ip_realwp_p) X(NPTS), Y(NPTS), DLAT(NPTS), DLON(NPTS)
+      REAL(kind=ip_realwp_p) XLAT0, XLON0, DELLAT, DELLON
+      INTEGER (kind=ip_intwp_p) I
+      DO 23000 I=1,NPTS
+         X(I) = (DLON(I) - XLON0)/DELLON + 1.0
+         Y(I) = (DLAT(I) - XLAT0)/DELLAT + 1.0
+23000 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE MODULE(U,V,LI,LJ)
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) LI,LJ
+      REAL(kind=ip_realwp_p) U(LI,LJ), V(LI,LJ)
+      INTEGER (kind=ip_intwp_p) I,J
+      DO 23000 I=1,LI
+         DO 23002 J=1,LJ
+            U(I,J)=SQRT(U(I,J)*U(I,J)+V(I,J)*V(I,J))
+23002    CONTINUE 
+23000 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE NWTNCOF(CX,CY,AX,AY,I1,I2,J1,J2)
+C*******
+C AUTEUR: Y. CHARTIER, DRPN
+C        FEVRIER 1991
+C
+C OBJET:  CALCUL DE COEFFICIENTS UTI1ISES DANS LA FORME NEWTONIENNE
+C        DE L'INTERPOLATION DE LAGRANGE.
+C
+C===========================================
+C
+C   -----*-------------*------#------*----------*------->
+C        X1            X2     X      X3         X4
+C
+C===========================================
+C     CX(I,1) = 1.0 / (X2-X1)
+C     CX(I,2) = 1.0 / (X3-X1)
+C     CX(I,3) = 1.0 / (X3-X2)
+C     CX(I,4) = 1.0 / (X4-X1)
+C     CX(I,5) = 1.0 / (X4-X2)
+C     CX(I,6) = 1.0 / (X4-X3)
+C
+C     STRUCTURE IDENTIQUE POUR CY(J,1..6)
+C*******
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) CX(I1:I2,6),CY(J1:J2,6),AX(I1:I2),AY(J1:J2)
+      INTEGER (kind=ip_intwp_p) I,J
+      DO 23000 I=I1+1,I2-2
+         CX(I,1) = 1. / (AX(I  ) - AX(I-1))
+         CX(I,2) = 1. / (AX(I+1) - AX(I-1))
+         CX(I,3) = 1. / (AX(I+1) - AX(I  ))
+         CX(I,4) = 1. / (AX(I+2) - AX(I-1))
+         CX(I,5) = 1. / (AX(I+2) - AX(I  ))
+         CX(I,6) = 1. / (AX(I+2) - AX(I+1))
+23000 CONTINUE 
+      DO 23002 J=J1+1,J2-2
+         CY(J,1) = 1. / (AY(J  ) - AY(J-1))
+         CY(J,2) = 1. / (AY(J+1) - AY(J-1))
+         CY(J,3) = 1. / (AY(J+1) - AY(J  ))
+         CY(J,4) = 1. / (AY(J+2) - AY(J-1))
+         CY(J,5) = 1. / (AY(J+2) - AY(J  ))
+         CY(J,6) = 1. / (AY(J+2) - AY(J+1))
+23002 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE POLRINT(ZO,XLAT,XLON,LILJ,ZI,NI,NJ,I1,I2,J1,J2,
+     $GRTYP,IG1,IG2,IG3,IG4,VECTEUR)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LILJ,NI,NJ,IG1,IG2,IG3,IG4
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) ZO(LILJ),XLAT(LILJ),XLON(LILJ)
+      REAL(kind=ip_realwp_p) ZI(I1:I2,J1:J2)
+      CHARACTER*1 GRTYP
+      LOGICAL VECTEUR
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+C-- COMMON QQQCOM1
+C--
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C----------------------
+C
+CDEFINITION DES VARIABLES LOCALES
+C
+
+      INTEGER (kind=ip_intwp_p) I,J
+      INTEGER (kind=ip_intwp_p) N1, N2, S1, S2
+      REAL(kind=ip_realwp_p) VPOLNOR, VPOLSUD
+      IF( (VECTEUR))THEN
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ. 'L'.OR. GRTYP.EQ. 'N'.OR. GRTYP.EQ. 'S'.OR.
+     $ GRTYP.EQ. 'Z' .OR. GRTYP .EQ. 'Y'))THEN
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ. 'B'))THEN
+         IF( (IG1.EQ. GLOBAL))THEN
+            VPOLNOR = ZI(0, NJ)
+            VPOLSUD = ZI(0, 1)
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            VPOLNOR = ZI(0, NJ)
+            VPOLSUD = ZI(0, -NJ+1)
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            VPOLNOR = ZI(0, 2*NJ-1)
+            VPOLSUD = ZI(0, 1)
+         ENDIF 
+      ENDIF 
+      IF( (GRTYP.EQ. 'A'.OR. GRTYP.EQ. 'G'))THEN
+         VPOLNOR = 0.0
+         VPOLSUD = 0.0
+         IF( (IG1.EQ. GLOBAL))THEN
+            N1 = NJ
+            N2 = NJ - 1
+            S1 = 1
+            S2 = 2
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            N1 = NJ
+            N2 = NJ - 1
+            S1 = -NJ+1
+            S2 = -NJ+2
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            N1 = 2*NJ
+            N2 = 2*NJ - 1
+            S1 = 1
+            S2 = 2
+         ENDIF 
+         IF( (PTPOLN))THEN
+            DO 23022 I=1,NI
+               VPOLNOR = VPOLNOR + 9.0 * ZI(I, N1) + ZI(I,N2)
+23022       CONTINUE 
+            VPOLNOR = 0.1 * VPOLNOR / REAL(NI,ip_realwp_p)
+         ENDIF 
+         IF( (PTPOLS))THEN
+            DO 23026 I=1,NI
+               VPOLSUD = VPOLSUD + 9.0 * ZI(I, S1) + ZI(I,S2)
+23026       CONTINUE 
+            VPOLSUD = 0.1 * VPOLSUD / REAL(NI,ip_realwp_p)
+         ENDIF 
+      ENDIF 
+      DO 23028 I=1,NPOLNUM
+         ZO(NPOLPTS(NPOLPTR+I-1)) = VPOLNOR
+23028 CONTINUE 
+      DO 23030 I=1,SPOLNUM
+         ZO(SPOLPTS(SPOLPTR+I-1)) = VPOLSUD
+23030 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE QQQALOC(XLAT, XLON, LI, LJ, I1, I2, J1, J2)
+      USE mod_kinds_oasis
+      USE memoir
+      IMPLICIT NONE
+C      EXTERNAL MEMOIRH
+      INTEGER (kind=ip_intwp_p) LI,LJ,I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) XLAT(LI,LJ), XLON(LI,LJ)
+C-- COMMON QQQCOM1
+C--
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C----------------------
+      CALL MEMOIRH(XGD, XGDPTR, LI*LJ, 0)
+      CALL MEMOIRH(YGD, YGDPTR, LI*LJ, 0)
+      CALL MEMOIRH(ZTMP,ZPTR,(I2-I1+1)*(J2-J1+1), 0)
+      CALL MEMOIRH(AXTMP,AXPTR,(I2-I1+1), 0)
+      CALL MEMOIRH(AYTMP,AYPTR,(J2-J1+1), 0)
+      CALL MEMOIRH(CXTMP,CXPTR, (I2-I1+1) * 6, 0)
+      CALL MEMOIRH(CYTMP,CYPTR, (J2-J1+1) * 6, 0)
+      CALL MEMOIRH(NPOLPTS, NPOLPTR, 128, 0)
+      CALL MEMOIRH(SPOLPTS, SPOLPTR, 128, 0)
+      NPOLMAX = 128
+      SPOLMAX = 128
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE QQQCHK(XLAT, XLON, LILJ)
+      USE mod_kinds_oasis
+      USE memoir
+      IMPLICIT NONE
+
+C-- COMMON QQQCOM1
+C--
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C----------------------
+
+      INTEGER (kind=ip_intwp_p) LILJ
+      REAL(kind=ip_realwp_p) XLAT(LILJ), XLON(LILJ)
+      REAL(kind=ip_realwp_p) TMP
+      LOGICAL BADLAT
+      INTEGER (kind=ip_intwp_p) NPOLPT2,SPOLPT2
+      INTEGER (kind=ip_intwp_p) I,J
+C  VERIF POUR POINT AU POLE
+
+      REAL(kind=ip_realwp_p) EPSILON
+      DATA EPSILON /1.0E-6/
+      BADLAT = .FALSE.
+      DO 23000 I=1,LILJ
+         TMP = XLON(I)
+         XLON(I)=MOD(MOD(XLON(I),360.0_ip_realwp_p)
+     $       +360.0_ip_realwp_p,360.0_ip_realwp_p)
+         TMP = XLAT(I)
+         XLAT(I)=MAX(-90.0_ip_realwp_p,
+     $       MIN(90.0_ip_realwp_p,XLAT(I)))
+         IF( (TMP.NE. XLAT(I)))THEN
+            BADLAT = .TRUE.
+         ENDIF 
+23000 CONTINUE 
+      IF( (BADLAT))THEN
+         WRITE(6,*) '<QQQGLAT> Latitudes gotten > 90.0 or < -90.0'
+         WRITE(6,*)
+     $    'Put latitudes back into -90.0 and +90.0'
+         WRITE(6,*) 'LAT. > 90.0 = 90.0, LAT < -90.0 = -90.0'
+      ENDIF 
+      PTPOLN = .FALSE.
+      NPOLNUM = 0
+      DO 23006 I=1,LILJ
+         IF( (EPSILON.GT. ABS(90.0 - XLAT(I))))THEN
+            IF( (NPOLNUM.EQ. NPOLMAX))THEN
+               CALL MEMOIRH(NPOLPTS, NPOLPT2, NPOLMAX+128, NPOLMAX)
+               NPOLPTR = NPOLPT2
+               NPOLMAX = NPOLMAX + 128
+            ENDIF 
+            PTPOLN = .TRUE.
+            NPOLPTS(NPOLPTR+NPOLNUM) = I
+            NPOLNUM = NPOLNUM + 1
+         ENDIF 
+23006 CONTINUE 
+      PTPOLS = .FALSE.
+      SPOLNUM = 0
+      DO 23016 I=1,LILJ
+         IF( (EPSILON.GT. ABS(-90.0 - XLAT(I))))THEN
+            IF( (SPOLNUM.EQ. SPOLMAX))THEN
+               CALL MEMOIRH(SPOLPTS, SPOLPT2, SPOLMAX+128, SPOLMAX)
+               SPOLPTR = SPOLPT2
+               SPOLMAX = SPOLMAX + 128
+            ENDIF 
+            PTPOLS = .TRUE.
+            SPOLPTS(SPOLPTR+SPOLNUM) = I
+            SPOLNUM = SPOLNUM + 1
+         ENDIF 
+23016 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      LOGICAL FUNCTION QQQCMP(XLAT, XLON, LILJ, NI, NJ,GRTYP, IG1,
+     $ IG2, IG3, IG4, XORSUM)
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) LILJ
+      REAL(kind=ip_realwp_p) XLAT(LILJ), XLON(LILJ)
+      INTEGER (kind=ip_intwp_p) NI, NJ, IG1, IG2, IG3, IG4, XORSUM
+      CHARACTER*1 GRTYP
+      INTEGER (kind=ip_intwp_p) XORCALC
+      CHARACTER*4 GRTMP
+C-- COMMON QQQCOM1
+C--
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C----------------------
+C-- COMMON QQQCOM2
+C-
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      INTEGER (kind=ip_intwp_p) LSTLILJ, LSTNI, LSTNJ, LSTXOR
+      INTEGER (kind=ip_intwp_p) LSTIG1, LSTIG2, LSTIG3, LSTIG4
+      COMMON /QQQCOM2/ I1,I2,J1,J2,LSTLILJ,LSTNI,LSTNJ,LSTIG1,LSTIG2
+     $,LSTIG3,LSTIG4,LSTXOR
+C-
+C------------
+C* COMMON QQQCOM3
+C
+
+      CHARACTER*1 LSTGTYP
+      COMMON /QQQCOM3/ LSTGTYP
+C------------
+
+      QQQCMP = .TRUE.
+      IF( (LILJ.NE.LSTLILJ.OR.NI.NE.LSTNI.OR.NJ.NE.LSTNJ))THEN
+         QQQCMP = .FALSE.
+      ENDIF 
+      GRTMP = GRTYP
+      IF( (IG1.NE.LSTIG1.OR.IG2.NE.LSTIG2.OR.IG3.NE.LSTIG3.OR.IG4
+     $.NE.LSTIG4.OR.GRTMP.NE.LSTGTYP))THEN
+         QQQCMP = .FALSE.
+      ENDIF 
+      XORSUM = XORCALC(XLAT, XLON, LILJ)
+      IF( (XORSUM.NE.LSTXOR))THEN
+         QQQCMP = .FALSE.
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      BLOCK DATA GAUSSGDBLK
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+C
+C-- COMMON GAUSSGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ROOTS,LROOTS
+      INTEGER (kind=ip_intwp_p) IROOTS, ILROOTS
+      COMMON /GAUSSGD/ ROOTS,LROOTS,IROOTS,ILROOTS
+C----------------------
+      DATA IROOTS, ILROOTS /0, 0/
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE QQQGLAT(NJ,HEM)
+C* ----------------------------------------------------------------------
+C* S/R QQQGLAT - CALCUL DES LATITUDES D'UNE GRILLE GAUSSIENNE
+C*
+C  AUTEUR: YVES CHARTIER. MARS 1991.
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      USE memoir
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) NJ, HEM
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+C-- COMMON GAUSSGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ROOTS,LROOTS
+      INTEGER (kind=ip_intwp_p) IROOTS, ILROOTS
+      COMMON /GAUSSGD/ ROOTS,LROOTS,IROOTS,ILROOTS
+C----------------------
+      EXTERNAL DGAUSS
+      EXTERNAL GAUSSGDBLK
+      INTEGER (kind=ip_intwp_p) J,NPOLY
+      INTEGER (kind=ip_intwp_p) NJ2
+      IF( (IROOTS.NE. 0))THEN
+         CALL MEMOIRH(ROOTS,  IROOTS, 0, 0)
+      ENDIF 
+      IF( (ILROOTS.NE. 0))THEN
+         CALL MEMOIRH(LROOTS,ILROOTS, 0, 0)
+      ENDIF 
+      IF( (HEM.NE. GLOBAL))THEN
+         NPOLY = NJ * 2
+      ELSE 
+         NPOLY = NJ
+      ENDIF 
+      CALL MEMOIRH(ROOTS, IROOTS, NPOLY, 0)
+      CALL MEMOIRH(LROOTS,ILROOTS,NPOLY, 0)
+      CALL DGAUSS(NPOLY, ROOTS(IROOTS), HEM)
+      IF( (HEM.EQ. GLOBAL))THEN
+          NJ2 = NJ / 2
+          DO 23008 J=1,NJ2
+            LROOTS(J-1+ILROOTS)=90.0-RDTODG*ACOS(ROOTS(IROOTS+NJ2-J)
+     $          )
+23008     CONTINUE 
+      ENDIF 
+      IF( (HEM.EQ. NORD))THEN
+         DO 23012 J=1,NJ
+            LROOTS(J-1+ILROOTS)=90.0-RDTODG*ACOS(ROOTS(IROOTS+NJ-J))
+23012    CONTINUE 
+      ENDIF 
+      IF( (HEM.EQ. SUD))THEN
+         DO 23016 J=1,NJ
+            LROOTS(ILROOTS-1+J)=-(90.0-RDTODG*ACOS(ROOTS(IROOTS-1+J)
+     $      ))
+23016    CONTINUE 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE QQQKEEP(LILJ,NI,NJ,GRTYP,IG1,IG2,IG3,IG4,XORSUM)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LILJ, NI, NJ, IG1, IG2, IG3, IG4, XORSUM
+      CHARACTER*1 GRTYP
+C-- COMMON QQQCOM2
+C-
+
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      INTEGER (kind=ip_intwp_p) LSTLILJ, LSTNI, LSTNJ, LSTXOR
+      INTEGER (kind=ip_intwp_p) LSTIG1, LSTIG2, LSTIG3, LSTIG4
+      COMMON /QQQCOM2/ I1,I2,J1,J2,LSTLILJ,LSTNI,LSTNJ,LSTIG1,LSTIG2
+     $,LSTIG3,LSTIG4,LSTXOR
+C-
+C------------
+C* COMMON QQQCOM3
+C
+
+      CHARACTER*1 LSTGTYP
+      COMMON /QQQCOM3/ LSTGTYP
+C------------
+
+      LSTLILJ = LILJ
+      LSTNI   = NI
+      LSTNJ   = NJ
+      LSTGTYP = GRTYP
+      LSTIG1  = IG1
+      LSTIG2  = IG2
+      LSTIG3  = IG3
+      LSTIG4  = IG4
+      LSTXOR  = XORSUM
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE QQQXTRAP(ZO, PX, PY, NPTS, Z, I1, I2, J1, J2)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) NPTS,I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) ZO(NPTS),PX(NPTS),PY(NPTS)
+      REAL(kind=ip_realwp_p) Z(I1:I2,J1:J2)
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      INTEGER (kind=ip_intwp_p) N, I, J, OFFL, OFFR
+      REAL(kind=ip_realwp_p) RMIN, RMAX, TEMPMIN, TEMPMAX
+      IF( (.NOT.FLGXTRAP))THEN
+         RETURN
+      ENDIF 
+      IF( (CODXTRAP.EQ. OUI))THEN
+         RETURN
+      ENDIF 
+      IF( (ORDINT.EQ. 3))THEN
+         OFFR = 2
+         OFFL = 1
+      ELSE 
+         OFFR = 0
+         OFFL = 0
+      ENDIF 
+      RMIN = Z(I1, J1)
+      RMAX = Z(I1, J1)
+      DO 23006 J=J1, J2
+         DO 23008 I=I1, I2
+            IF( (Z(I,J).LT. RMIN))THEN
+               RMIN = Z(I,J)
+            ENDIF 
+            IF( (Z(I,J).GT. RMAX))THEN
+               RMAX = Z(I,J)
+            ENDIF 
+23008    CONTINUE 
+23006 CONTINUE 
+      TEMPMIN = RMIN - 0.25*(RMAX - RMIN)
+      TEMPMAX = RMAX + 0.25*(RMAX - RMIN)
+      RMIN = TEMPMIN
+      RMAX = TEMPMAX
+      DO 23014 N=1, NPTS
+         I = INT(PX(N))
+         J = INT(PY(N))
+         IF( (I.LT.(I1+OFFL).OR. J.LT.(J1+OFFL).OR. I.GT. (I2-OFFR)
+     $   .OR. J.GT. (J2-OFFR)))THEN
+            IF( (CODXTRAP.EQ. VOISIN))THEN
+               I = MIN(I2, MAX(I1, NINT(PX(N))))
+               J = MIN(J2, MAX(J1, NINT(PY(N))))
+               ZO(N) = Z(I,J)
+            ENDIF 
+            IF( (CODXTRAP.EQ. MINIMUM))THEN
+               ZO(N) = RMIN
+            ENDIF 
+            IF( (CODXTRAP.EQ. MAXIMUM))THEN
+               ZO(N) = RMAX
+            ENDIF 
+            IF( (CODXTRAP.EQ. VALEUR))THEN
+               ZO(N) = VALXTRAP
+            ENDIF 
+         ENDIF 
+23014 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGDINT(ZO,PX,PY,NPTS,Z,I1,I2,J1,J2)
+C*******
+C AUTEUR: Y.CHARTIER, DRPN
+C        FEVRIER 1991
+C
+C OBJET:  INTERPOLATION BI-CUBIQUE DE POINTS A PARTIR D'UNE GRILLE
+C        SOURCE REGULIERE.
+C
+C*******
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) NPTS,I1,I2,J1,J2
+      REAL(kind=ip_realwp_p) ZO(NPTS),PX(NPTS),PY(NPTS)
+      REAL(kind=ip_realwp_p) Z(I1:I2,J1:J2)
+C
+C  NPTS   : NOMBRE DE POINTS A INTERPOLER
+C  I1:I2  : DIMENSION DE LA GRILLE SOURCE SELON X
+C  J1:J2  : DIMENSION DE LA GRILLE SOURCE SELON Y
+C  ZO     : VECTEUR DE SORTIE CONTENANT LES VALEURS INTERPOLEES
+C  PX     : VECTEUR CONTENANT LA POSITION X DES POINTS QUE L'ON
+C         : VEUT INTERPOLER
+C  PY     : VECTEUR CONTENANT LA POSITION Y DES POINTS QUE L'ON
+C         : VEUT INTERPOLER
+C  Z      : VALEURS DE LA GRILLE SOURCE.
+C
+C===========================================
+C
+C     *   *   *   *
+C
+C     *   *   *   *
+C           #        ==>   PT (X,Y)
+C     *  (=)  *   *  ==> = PT (IIND, JIND)
+C
+C     *   *   *   *
+C
+C===========================================
+
+      REAL(kind=ip_realwp_p) Y1,Y2,Y3,Y4
+      INTEGER (kind=ip_intwp_p) M,N,I,J,STRIDE
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      REAL(kind=ip_realwp_p) CUBIC, DX,DY,Z1,Z2,Z3,Z4
+      REAL(kind=ip_realwp_p) ZLIN, ZZ1, ZZ2, ZDX
+      CUBIC(Z1,Z2,Z3,Z4,DX)=((((Z4-Z1)*0.1666666666666 + 0.5*(Z2-Z3)
+     $)*DX + 0.5*(Z1+Z3)-Z2)*DX + Z3-0.1666666666666*Z4-0.5*Z2-0.
+     $3333333333333*Z1)*DX+Z2
+      ZLIN(ZZ1,ZZ2,ZDX) = ZZ1 + (ZZ2 - ZZ1) * ZDX
+      STRIDE = 1
+      IF( (ORDINT.EQ. CUBIQUE))THEN
+         DO 23002 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            DX = PX(N) - I
+            DY = PY(N) - J
+            Y1=CUBIC(Z(I-1,J-1),Z(I  ,J-1),Z(I+1,J-1),Z(I+2,J-1),DX)
+            Y2=CUBIC(Z(I-1,J  ),Z(I  ,J  ),Z(I+1,J  ),Z(I+2,J  ),DX)
+            Y3=CUBIC(Z(I-1,J+1),Z(I  ,J+1),Z(I+1,J+1),Z(I+2,J+1),DX)
+            Y4=CUBIC(Z(I-1,J+2),Z(I  ,J+2),Z(I+1,J+2),Z(I+2,J+2),DX)
+            ZO(N)=CUBIC(Y1,Y2,Y3,Y4,DY)
+23002    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. LINEAIR))THEN
+         DO 23006 N=1,NPTS
+            I = MIN(I2-2,MAX(I1+1,INT(PX(N))))
+            J = MIN(J2-2,MAX(J1+1,INT(PY(N))))
+            DX = PX(N) - I
+            DY = PY(N) - J
+            Y2=ZLIN(Z(I,J  ),Z(I+1,J  ),DX)
+            Y3=ZLIN(Z(I,J+1),Z(I+1,J+1),DX)
+            ZO(N)=ZLIN(Y2,Y3,DY)
+23006    CONTINUE 
+      ENDIF 
+      IF( (ORDINT.EQ. VOISIN))THEN
+         DO 23010 N=1,NPTS
+            I = MIN(I2,MAX(I1,NINT(PX(N))))
+            J = MIN(J2,MAX(J1,NINT(PY(N))))
+            ZO(N)=Z(I,J)
+23010    CONTINUE 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGFREE()
+      USE mod_kinds_oasis
+      USE memoir
+      IMPLICIT NONE
+C
+C* - COMMON QQQCOM1
+C
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: XGD, YGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ZTMP,AXTMP,
+     $     AYTMP,CXTMP,CYTMP
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), POINTER :: NPOLPTS, 
+     $     SPOLPTS
+      INTEGER (kind=ip_intwp_p) XGDPTR,YGDPTR
+      INTEGER (kind=ip_intwp_p) ZPTR, AXPTR, AYPTR, CXPTR, CYPTR
+      INTEGER (kind=ip_intwp_p) NPOLPTR, SPOLPTR, NPOLNUM,SPOLNUM,
+     $     NPOLMAX,SPOLMAX
+      LOGICAL PTPOLN, PTPOLS
+      COMMON /QQQCOM1/ XGD,YGD,ZTMP,AXTMP,AYTMP,CXTMP,CYTMP,XGDPTR,
+     $YGDPTR,ZPTR,AXPTR,AYPTR,CXPTR,CYPTR,NPOLPTS,SPOLPTS,NPOLPTR,
+     $ SPOLPTR,NPOLNUM,SPOLNUM,NPOLMAX,SPOLMAX,PTPOLN, PTPOLS
+C
+C* - COMMON QQQCOM2
+C
+
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2
+      INTEGER (kind=ip_intwp_p) LSTLILJ, LSTNI, LSTNJ, LSTXOR
+      INTEGER (kind=ip_intwp_p) LSTIG1, LSTIG2, LSTIG3, LSTIG4
+      COMMON /QQQCOM2/ I1,I2,J1,J2,LSTLILJ,LSTNI,LSTNJ,LSTIG1,LSTIG2
+     $,LSTIG3,LSTIG4,LSTXOR
+C
+C* - COMMON QQQCOM3
+C
+
+      CHARACTER*1 LSTGTYP
+      COMMON /QQQCOM3/ LSTGTYP
+C* -----------------------------------------------------------------------
+      IF( (XGDPTR.NE.0))THEN
+         CALL MEMOIRH(XGD, XGDPTR, 0, 0)
+         XGDPTR = 0
+      ENDIF 
+      IF( (YGDPTR.NE.0))THEN
+         CALL MEMOIRH(YGD, YGDPTR, 0, 0)
+         YGDPTR = 0
+      ENDIF 
+      IF( (ZPTR.NE.0))THEN
+         CALL MEMOIRH(ZTMP,ZPTR, 0, 0)
+         ZPTR = 0
+      ENDIF 
+      IF( (AXPTR.NE.0))THEN
+         CALL MEMOIRH(AXTMP,AXPTR, 0, 0)
+         AXPTR = 0
+      ENDIF 
+      IF( (AYPTR.NE.0))THEN
+         CALL MEMOIRH(AYTMP,AYPTR, 0, 0)
+         AYPTR = 0
+      ENDIF 
+      IF( (CXPTR.NE.0))THEN
+         CALL MEMOIRH(CXTMP, CXPTR, 0, 0)
+         CXPTR = 0
+      ENDIF 
+      IF( (CYPTR.NE.0))THEN
+         CALL MEMOIRH(CYTMP, CYPTR, 0, 0)
+         CYPTR = 0
+      ENDIF 
+      IF( (NPOLPTR.NE.0))THEN
+         CALL MEMOIRH(NPOLPTS, NPOLPTR, 0, 0)
+         NPOLPTR = 0
+         NPOLMAX = 0
+      ENDIF 
+      IF( (SPOLPTR.NE.0))THEN
+         CALL MEMOIRH(SPOLPTS, SPOLPTR, 0, 0)
+         SPOLPTR = 0
+         SPOLMAX = 0
+      ENDIF 
+      LSTLILJ = 0
+      LSTNI   = 0
+      LSTNJ   = 0
+      LSTGTYP = ' '
+      LSTIG1  = 0
+      LSTIG2  = 0
+      LSTIG3  = 0
+      LSTIG4  = 0
+      LSTXOR  = 0
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGLL2GD(SPDO,PSIO,XLON,LI,LJ,GRTYP,IG1,IG2,IG3,IG4)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) LI,LJ
+      REAL(kind=ip_realwp_p) SPDO(LI,LJ), PSIO(LI,LJ), XLON(LI,LJ)
+      CHARACTER*1 GRTYP
+      INTEGER (kind=ip_intwp_p) IG1,IG2,IG3,IG4
+      EXTERNAL CIGAXG
+C
+C AUTEUR   - Y. CHARTIER - AVRIL 91
+C
+C OBJET(RGLL2GD)
+C         - PASSE DE PSIOTESSE ET DIRECTION
+C         - A VENT DE GRILLE (COMPOSANTES U ET V)
+C
+C APPEL    - CALL RGLL2GD(SPD,PSI,LI,LJ,IYP,XG1,XG2,XG3,XG4)
+C
+C MODULES  - XGAIG
+C
+C ARGUMENTS
+C  IN/OUT - SPD   - A L'ENTREE CONTIENT LA PSIOTESSE DU VENT ET
+C                   A LA SORTIE LA COMPOSANTE U.
+C  IN/OUT - PSI   - A L'ENTREE CONTIENT LA DIRECTION DU VENT ET
+C                   A LA SORTIE LA COMPOSANTE V.
+C   IN    - LI    - PREMIERE DIMENSION DES CHAMPS SPD ET PSI
+C   IN    - LJ    - DEUXIEME DIMENSION DES CHAMPS SPD ET PSI
+C   IN    - IGTYP  - TYPE DE GRILLE (VOIR OUVRIR)
+C   IN    - XG1   - ** DESCRIPTEUR DE GRILLE (REEL),
+C   IN    - XG2   -    IGTYP = 'N', PI, PJ, D60, DGRW
+C   IN    - XG3   -    IGTYP = 'L', LAT0, LON0, DLAT, DLON,
+C   IN    - XG4   -    IGTYP = 'A', 'B', 'G', XG1 = 0. GLOBAL,
+C                                                 = 1. NORD
+C                                                 = 2. SUD **
+C
+CMESSAGES - "ERREUR MAUVAISE GRILLE (RGLL2GD)"
+C
+C-------------------------------------------------------------
+C
+C
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+
+      INTEGER (kind=ip_intwp_p) I,J
+      REAL(kind=ip_realwp_p) PSI,U,V
+      REAL(kind=ip_realwp_p) XG1, XG2, XG3, XG4
+      IF( (GRTYP.EQ. 'N'))THEN
+         CALL CIGAXG(GRTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+         DO 23002 I=1,LI
+            DO 23004 J=1,LJ
+               PSI =XLON(I,J)+XG4-PSIO(I,J)
+               U = COS(PSI*DGTORD)*SPDO(I,J)
+               V = SIN(PSI*DGTORD)*SPDO(I,J)
+               SPDO(I,J) = U
+               PSIO(I,J) = V
+23004       CONTINUE 
+23002    CONTINUE 
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ. 'S'))THEN
+         CALL CIGAXG(GRTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+         DO 23008 I=1,LI
+            DO 23010 J=1,LJ
+               PSI =180.0 - XLON(I,J)+XG4-PSIO(I,J)
+               U = COS(PSI*DGTORD)*SPDO(I,J)
+               V = SIN(PSI*DGTORD)*SPDO(I,J)
+               SPDO(I,J) = U
+               PSIO(I,J) = V
+23010       CONTINUE 
+23008    CONTINUE 
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ.'A'.OR.GRTYP.EQ.'B'.OR.GRTYP.EQ.'G'.OR.GRTYP.EQ.
+     $'L'))THEN
+         DO 23014 I=1,LI
+            DO 23016 J=1,LJ
+               PSI = 270.0 - PSIO(I,J)
+               U = COS(PSI*DGTORD)*SPDO(I,J)
+               V = SIN(PSI*DGTORD)*SPDO(I,J)
+               SPDO(I,J) = U
+               PSIO(I,J) = V
+23016       CONTINUE 
+23014    CONTINUE 
+         RETURN
+      ENDIF 
+      WRITE(6, 600) GRTYP
+600   FORMAT('0',' Error, bad grid (RGLL2GD) - GRTYP = ', A1)
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGOPTC(OP, VAL, FLAG)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      CHARACTER *(*) OP, VAL
+      LOGICAL FLAG
+CFLAG = .TRUE.  MODE SET
+CFLAG = .FALSE. MODE GET
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      IF( (FLAG))THEN
+         IF( (OP.EQ.  'EXTRAP'))THEN
+            IF( (VAL.EQ.  'OUI'))THEN
+               CODXTRAP = OUI
+            ELSE 
+               IF( (VAL.EQ.  'ABORT'))THEN
+                  CODXTRAP = ABORT
+               ELSE 
+                  IF( (VAL.EQ.  'MAXIMUM'))THEN
+                     CODXTRAP = MAXIMUM
+                  ELSE 
+                     IF( (VAL.EQ.  'MINIMUM'))THEN
+                        CODXTRAP = MINIMUM
+                     ELSE 
+                        IF( (VAL.EQ.  'VOISIN'))THEN
+                           CODXTRAP = VOISIN
+                        ELSE 
+                           IF( (VAL.EQ.  'VALEUR'))THEN
+                              CODXTRAP = VALEUR
+                           ELSE 
+                              WRITE(6,*)
+     $                         ' <RGOPTC>: bad value for VAL'
+                              WRITE(6,*) '           VAL = ', VAL
+                              WRITE(6,*)
+     $                         '           VAL initialized to ''ABORT'''
+                              CODXTRAP = ABORT
+                           ENDIF 
+                        ENDIF 
+                     ENDIF 
+                  ENDIF 
+               ENDIF 
+            ENDIF 
+         ELSE 
+            IF( (OP.EQ.  'INTERP'.OR.  OP.EQ.  'INTERP'))THEN
+               IF( (VAL.EQ.  'VOISIN'))THEN
+                  ORDINT = VOISIN
+               ELSE 
+                  IF( (VAL.EQ.  'LINEAIR'))THEN
+                     ORDINT = LINEAIR
+                  ELSE 
+                     IF( (VAL.EQ.  'CUBIQUE'))THEN
+                        ORDINT = CUBIQUE
+                     ELSE 
+                        WRITE(6,*)
+     $                   ' <RGOPTC>: bad value for VAL'
+                        WRITE(6,*) '           VAL = ', VAL
+                        WRITE(6,*)
+     $                   '           VAL initialized to ''CUBIQUE'''
+                        ORDINT = CUBIQUE
+                     ENDIF 
+                  ENDIF 
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTC>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' or ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ELSE 
+         IF( (OP.EQ.  'EXTRAP'))THEN
+            IF( (CODXTRAP.EQ.  OUI))THEN
+               VAL = 'OUI'
+            ELSE 
+               IF( (CODXTRAP.EQ.  ABORT))THEN
+                  VAL = 'ABORT'
+               ELSE 
+                  IF( (CODXTRAP.EQ.  MAXIMUM))THEN
+                     VAL = 'MAXIMUM'
+                  ELSE 
+                     IF( (CODXTRAP.EQ.  MINIMUM))THEN
+                        VAL = 'MINIMUM'
+                     ELSE 
+                        IF( (CODXTRAP.EQ.  VOISIN))THEN
+                           VAL = 'VOISIN'
+                        ELSE 
+                           IF( (CODXTRAP.EQ.  VALEUR))THEN
+                              VAL = 'VALEUR'
+                           ELSE 
+                              WRITE(6,*)
+     $ ' <RGOPTC>: bad value for CODXTRAP'
+                              WRITE(6,*) '           CODXTRAP = ',
+     $                         CODXTRAP
+                              VAL = 'SCRAP'
+                           ENDIF 
+                        ENDIF 
+                     ENDIF 
+                  ENDIF 
+               ENDIF 
+            ENDIF 
+         ELSE 
+            IF( (OP.EQ.  'INTERP'))THEN
+               IF( (ORDINT.EQ.  VOISIN))THEN
+                  VAL = 'VOISIN'
+               ELSE 
+                  IF( (ORDINT.EQ.  LINEAIR))THEN
+                     VAL = 'LINEAIR'
+                  ELSE 
+                     IF( (ORDINT.EQ.  CUBIQUE))THEN
+                        VAL = 'CUBIQUE'
+                     ELSE 
+                        WRITE(6,*)
+     $                   ' <RGOPTC>: bad value for ORDINT'
+                        WRITE(6,*) '           ORDINT = ', ORDINT
+                        VAL = 'SCRAP'
+                     ENDIF 
+                  ENDIF 
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTC>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' OU ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      BLOCK DATA QQQXTRPBLK
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) OUI
+      PARAMETER (OUI   =   1)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      DATA CODXTRAP / OUI /
+      DATA FLGXTRAP / .FALSE. /
+      DATA ORDINT   / 3 /
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGOPTI(OP, VAL, FLAG)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      CHARACTER *(*) OP
+      INTEGER (kind=ip_intwp_p) VAL
+      LOGICAL FLAG
+CFLAG = .TRUE.  MODE SET
+CFLAG = .FALSE. MODE GET
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      EXTERNAL QQQXTRPBLK
+      IF( (FLAG))THEN
+         IF( (OP.EQ.  'EXTRAP'))THEN
+            VALXTRAP = REAL(VAL,ip_realwp_p)
+         ELSE 
+            IF( (OP.EQ.  'INTERP'))THEN
+               IF( (VAL.EQ.  VOISIN.OR.  VAL.EQ.  LINEAIR.OR.  VAL
+     $         .EQ. CUBIQUE))THEN
+                  ORDINT = VAL
+               ELSE 
+                  WRITE(6,*) ' <RGOPTI>: bad value for VAL'
+                  WRITE(6,*) '           VAL = ', VAL
+                  WRITE(6,*)
+     $             '           VAL initialized to ''CUBIQUE'''
+                  ORDINT = CUBIQUE
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTI>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' or ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ELSE 
+         IF( (OP.EQ.  'EXTRAP'))THEN
+            VAL = NINT(VALXTRAP)
+         ELSE 
+            IF( (OP.EQ.  'INTERP'))THEN
+               IF( (ORDINT.EQ.  VOISIN.OR.  ORDINT.EQ.  LINEAIR.OR.
+     $          ORDINT.EQ.  CUBIQUE))THEN
+                  VAL = ORDINT
+               ELSE 
+                  WRITE(6,*) ' <RGOPTI>: bad value for ORDINT'
+                  WRITE(6,*) '           ORDINT = ', ORDINT
+                  VAL = -1
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTI>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' or ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE RGOPTR(OP, VAL, FLAG)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      CHARACTER *(*) OP
+      REAL(kind=ip_realwp_p) VAL
+      LOGICAL FLAG
+C  FLAG = .TRUE.  MODE SET
+C  FLAG = .FALSE. MODE GET
+
+      INTEGER (kind=ip_intwp_p) VOISIN, LINEAIR, CUBIQUE
+      INTEGER (kind=ip_intwp_p) OUI, ABORT, VALEUR, MAXIMUM, MINIMUM
+      PARAMETER (VOISIN  =   0)
+      PARAMETER (LINEAIR =   1)
+      PARAMETER (CUBIQUE =   3)
+      PARAMETER (OUI   =   1)
+      PARAMETER (MINIMUM =   2)
+      PARAMETER (MAXIMUM =   3)
+      PARAMETER (VALEUR  =   4)
+      PARAMETER (ABORT   =  13)
+      LOGICAL FLGXTRAP
+      INTEGER (kind=ip_intwp_p) CODXTRAP, ORDINT
+      REAL(kind=ip_realwp_p) VALXTRAP
+      COMMON /QQQXTRP/ ORDINT, FLGXTRAP, CODXTRAP, VALXTRAP
+      IF( (FLAG))THEN
+         IF( (OP.EQ. 'EXTRAP'))THEN
+            VALXTRAP = VAL
+         ELSE 
+            IF( (OP.EQ. 'INTERP'))THEN
+               IF( (VAL.EQ. VOISIN.OR. VAL.EQ. LINEAIR.OR. VAL.EQ.
+     $          CUBIQUE))THEN
+                  ORDINT = NINT(VAL)
+               ELSE 
+                  WRITE(6,*)' <RGOPTR>: bad value for VAL'
+                  WRITE(6,*) '           VAL = ', VAL
+                  WRITE(6,*)
+     $             '           VAL initialized to ''CUBIQUE'''
+                  ORDINT = CUBIQUE
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTR>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' or ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ELSE 
+         IF( (OP.EQ. 'EXTRAP'))THEN
+            VAL = VALXTRAP
+         ELSE 
+            IF( (OP.EQ. 'INTERP'))THEN
+               IF( (ORDINT.EQ. VOISIN.OR. ORDINT.EQ. LINEAIR.OR.
+     $          ORDINT.EQ. CUBIQUE))THEN
+                  VAL = REAL(ORDINT,ip_realwp_p)
+               ELSE 
+                  WRITE(6,*) ' <RGOPTR>: bad value for ORDINT'
+                  WRITE(6,*) '           ORDINT = ', ORDINT
+                  VAL = REAL(ORDINT,ip_realwp_p)
+               ENDIF 
+            ELSE 
+               WRITE(6,*) ' <RGOPTR>: bad value for OP'
+               WRITE(6,*)
+     $ '           OP should be equal to ''EXTRAP'' OU ''INTERP'''
+            ENDIF 
+         ENDIF 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE VLLFXY(DLAT,DLON,X,Y,NI,NJ,D60,DGRW,PI,PJ,NHEM)
+C* ----------------------------------------------------------------------
+C* S/R VLLFXY(I) - COMPUTES THE GRID CO-ORDINATES OF A POINT
+C* ----------------------------------------------------------------------
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+C* ----------------------------------------------------------------------
+C* ARGUMENTS
+C   OUT   - DLAT - LATITUDE IN DEGREES (-90 TO +90, POSITIVE N).
+C         - DLON - LONGITUDE IN DEGREES (-180 TO +180, POSITIVE E).
+C   IN    - X    - X-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C         - Y    - Y-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C         - D60  - GRID LENGTH (IN METRES) OF THE POLAR STEREOGRAPHIC
+C                  GRID AT 60 DEGREES
+C         - DGRW - ORIENTATION OF GREENWICH MERIDIAN WITH RESPECT TO
+C                  THE GRID (IN DEGREES)
+C         - NHEM - 1 FOR NORTHERN HEMISPHERE
+C                  2 FOR SOUTHERN HEMISPHERE
+C
+CNOTES    - THE COMPANION ROUTINE XYFLL, WHICH COMPUTES THE GRID
+C           CO-ORDINATES GIVEN THE LATITUDE AND LONGITUDE, IS ALSO
+C           AVAILABLE.
+C
+C-----------------------------------------------------------------------
+C
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      INTEGER (kind=ip_intwp_p) NI,NJ, NHEM
+      REAL(kind=ip_realwp_p) X(NI,NJ), Y(NI,NJ), DLAT(NI,NJ), 
+     $     DLON(NI,NJ)
+      REAL(kind=ip_realwp_p) X1, Y1
+      REAL(kind=ip_realwp_p) D60, DGRW, PI, PJ
+      REAL(kind=ip_realwp_p) RE,RE2,R2,RLON,RLAT,SINLAT,R
+      INTEGER (kind=ip_intwp_p) I,J
+      RE=1.866025*6.371E+6/D60
+      RE2=RE**2
+      DO 23000 I=1,NI
+         DO 23002 J=1,NJ
+            X1 = X(I,J) - PI
+            Y1 = Y(I,J) - PJ
+            IF( (X1.EQ. 0..AND. Y1.EQ. 0.))THEN
+               DLAT(I,J)=90.
+               DLON(I,J)=0.
+
+C
+C  CALCULATE LONGITUDE IN MAP COORDINATES.
+C
+            ENDIF 
+            IF((X1.EQ. 0.))THEN
+               DLON(I,J)=SIGN(90._ip_realwp_p,Y1)
+            ENDIF 
+            IF((X1.NE. 0.))THEN
+               DLON(I,J)=ATAN(Y1/X1)*RDTODG
+            ENDIF 
+            IF((X1.LT.  0.))THEN
+               DLON(I,J)=DLON(I,J)+SIGN(180._ip_realwp_p,Y1)
+C
+C  * ADJUST LONGITUDE FOR GRID ORIENTATION.
+C
+
+            ENDIF 
+            DLON(I,J)=DLON(I,J)-DGRW
+            IF((DLON(I,J).GT.  180.))THEN
+               DLON(I,J)=DLON(I,J)-360.
+            ENDIF 
+            IF((DLON(I,J).LT. -180.))THEN
+               DLON(I,J)=DLON(I,J)+360.
+C
+C     * CALCULATE LATITUDE.
+C
+
+            ENDIF 
+            R2=X1**2+Y1**2
+            DLAT(I,J)=(RE2-R2)/(RE2+R2)
+            DLAT(I,J)= ASIN(DLAT(I,J))*RDTODG
+C
+C     CHANGE SIGNS IF IN SOUTHERN HEMISPHERE.
+C
+
+            IF((NHEM.EQ. 2))THEN
+               DLAT(I,J)=-DLAT(I,J)
+            ENDIF 
+            IF((NHEM.EQ. 2))THEN
+               DLON(I,J)=-DLON(I,J)
+            ENDIF 
+23002    CONTINUE 
+23000 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE VXYFLL(X,Y,DLAT,DLON,NPTS,D60,DGRW,PI,PJ,NHEM)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+
+C AUTHOR   - J.D. HENDERSON  -  FEB 75
+C
+C OBJECT(VXYFLL)
+C     - COMPUTES THE GRID CO-ORDINATES MEASURED FROM THE POLE OF A
+C       POINT, GIVEN THE LATITUDE AND LONGITUDE IN DEGREES.
+C
+C USAGE    - CALL VXYFLL(X,Y,DLAT,DLON,NPTS,D60,DGRW,PI,PJ,NHEM)
+C
+C ARGUMENTS
+C   OUT   - X    - X-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C         - Y    - Y-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C   IN    - DLAT - LATITUDE IN DEGREES (-90 TO +90, POSITIVE N)
+C         - DLON - LONGITUDE IN DEGREES (-180 TO +180, POSITIVE E)
+C         - D60  - GRID LENGTH (IN METRES) OF THE POLAR STEREOGRAPHIC
+C                  GRID AT 60 DEGREES
+C         - DGRW - ORIENTATION OF GREENWICH MERIDIAN WITH RESPECT TO
+C                  THE GRID (IN DEGREES)
+C         - NHEM - 1 FOR NORTHERN HEMISPHERE
+C                  2 FOR SOUTHERN HEMISPHERE
+C
+C NOTES    - THE COMPANION ROUTINE LLFXY, WHICH COMPUTES THE LATITUDE
+C         - AND LONGITUDE GIVEN THE GRID-COORDINATES,
+C         - IS ALSO AVAILABLE.
+C*--------------------------------------------------------------------
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      INTEGER (kind=ip_intwp_p) NPTS, NHEM
+      REAL(kind=ip_realwp_p) X(NPTS), Y(NPTS), DLAT(NPTS), DLON(NPTS)
+      REAL(kind=ip_realwp_p) D60, DGRW, PI, PJ
+      REAL(kind=ip_realwp_p) RE,RLON,RLAT,SINLAT,R
+      INTEGER (kind=ip_intwp_p) I
+      RE=1.866025*6.371E+6/D60
+C
+
+      IF( (NHEM.EQ.NORD))THEN
+         DO 23002 I=1,NPTS
+            RLON=DGTORD*(DLON(I)+DGRW)
+            RLAT=DGTORD*DLAT(I)
+            SINLAT=SIN(RLAT)
+            R=RE*SQRT((1.-SINLAT)/(1.+SINLAT))
+            X(I)=R*COS(RLON) + PI
+            Y(I)=R*SIN(RLON) + PJ
+23002    CONTINUE 
+         RETURN
+      ENDIF 
+      IF( (NHEM.EQ.SUD))THEN
+         DO 23006 I=1,NPTS
+            RLON = DLON(I)
+            IF( (RLON.GT. 180.0))THEN
+               RLON = RLON - 360.0
+            ENDIF 
+            RLON=DGTORD*(-RLON+DGRW)
+            RLAT=DGTORD*(-DLAT(I))
+            SINLAT=SIN(RLAT)
+            R=RE*SQRT((1.-SINLAT)/(1.+SINLAT))
+            X(I)=R*COS(RLON)+PI
+            Y(I)=R*SIN(RLON)+PJ
+23006    CONTINUE 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      FUNCTION XORCALC(ILAT, ILON, LILJ)
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) XORCALC
+      INTEGER (kind=ip_intwp_p) LILJ
+      INTEGER (kind=ip_intwp_p) ILAT(LILJ), ILON(LILJ)
+      XORCALC = 0
+      DO 23000 I=1,LILJ,17
+         XORCALC = IEOR(IEOR(XORCALC,ILAT(I)),ILON(I))
+23000 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE XPNAXEG(NEWAXEX,NEWAXEY,I1,I2,J1,J2,NI,NJ,HEM)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2,NI,NJ,HEM
+      REAL(kind=ip_realwp_p) NEWAXEX(I1:I2)
+      REAL(kind=ip_realwp_p) NEWAXEY(J1:J2)
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C
+C RDTODG = 180/PIE, DGTORD = PIE/180
+
+      REAL(kind=ip_realwp_p) PIE,RDTODG,DGTORD
+      DATA PIE   /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C
+C-- COMMON GAUSSGD
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER :: ROOTS,LROOTS
+      INTEGER (kind=ip_intwp_p) IROOTS, ILROOTS
+      COMMON /GAUSSGD/ ROOTS,LROOTS,IROOTS,ILROOTS
+C----------------------
+
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      INTEGER (kind=ip_intwp_p) I,J
+      DO 23000 I=1,NI
+         NEWAXEX(I) = REAL(I,ip_realwp_p)
+23000 CONTINUE 
+      NEWAXEX(0) = NEWAXEX(NI) - REAL(NI,ip_realwp_p)
+      NEWAXEX(NI+1) = NEWAXEX(1) + REAL(NI,ip_realwp_p)
+      NEWAXEX(NI+2) = NEWAXEX(2) + REAL(NI,ip_realwp_p)
+      IF( (HEM.EQ. NORD))THEN
+         DO 23004 J=1,NJ
+            NEWAXEY(J) = LROOTS(ILROOTS-1+J)
+23004    CONTINUE 
+         NEWAXEY(NJ+1) = 180.0 - NEWAXEY(NJ)
+         NEWAXEY(NJ+2) = 180.0 - NEWAXEY(NJ-1)
+         DO 23006 J=-NJ+1,0
+            NEWAXEY(J) = -(NEWAXEY(-J+1))
+23006    CONTINUE 
+         NEWAXEY(-NJ  ) = -180.0 - NEWAXEY(-NJ+1)
+         NEWAXEY(-NJ-1) = -180.0 - NEWAXEY(-NJ+2)
+      ENDIF 
+      IF( (HEM.EQ. SUD))THEN
+         DO 23010 J=1,NJ
+            NEWAXEY(J) = -(LROOTS(ILROOTS-1+NJ-J+1))
+            NEWAXEY(NJ+J) = LROOTS(ILROOTS-1+NJ-J+1)
+23010    CONTINUE 
+         NEWAXEY(0 ) = -180.0 - NEWAXEY(1)
+         NEWAXEY(-1) = -180.0 - NEWAXEY(2)
+         NEWAXEY(NJ+1) = 180.0 - NEWAXEY(2*NJ)
+         NEWAXEY(NJ+2) = 180.0 - NEWAXEY(2*NJ-1)
+      ENDIF 
+      IF( (HEM.EQ. GLOBAL))THEN
+         IF( (0.EQ. MOD(NJ,2)))THEN
+            DO 23016 J=1,NJ/2
+               NEWAXEY(J)   =  -(LROOTS(ILROOTS-1+NJ/2-J+1))
+               NEWAXEY(NJ/2+J) = LROOTS(ILROOTS-1+J)
+23016       CONTINUE 
+         ELSE 
+            DO 23018 J=1,NJ/2
+               NEWAXEY(J)   =  -(LROOTS(ILROOTS-1+NJ/2-J+1))
+               NEWAXEY(NJ/2+J+1) = LROOTS(ILROOTS-1+J)
+23018       CONTINUE 
+            NEWAXEY(NJ/2+1) = 0.0
+         ENDIF 
+         NEWAXEY(0 ) = -180.0 - NEWAXEY(1)
+         NEWAXEY(-1) = -180.0 - NEWAXEY(2)
+         NEWAXEY(NJ+1) = 180.0 - NEWAXEY(NJ)
+         NEWAXEY(NJ+2) = 180.0 - NEWAXEY(NJ-1)
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE XPNAXEZ(NEWAXEX,NEWAXEY,I1,I2,J1,J2,AX,AY,NI,NJ)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2,NI,NJ
+      REAL(kind=ip_realwp_p) NEWAXEX(I1:I2)
+      REAL(kind=ip_realwp_p) NEWAXEY(J1:J2)
+      REAL(kind=ip_realwp_p) AX(NI)
+      REAL(kind=ip_realwp_p) AY(NJ)
+      INTEGER (kind=ip_intwp_p) I,J
+      DO 23000 I=1,NI
+         NEWAXEX(I) = AX(I)
+23000 CONTINUE 
+      NEWAXEX(0) = NEWAXEX(NI) - AX(NI)
+      NEWAXEX(NI+1) = NEWAXEX(1) + AX(NI)
+      NEWAXEX(NI+2) = NEWAXEX(2) + AX(NI)
+      DO 23002 J=1,NJ
+         NEWAXEY(J) = AY(J)
+23002 CONTINUE 
+      NEWAXEY(0 ) = -180.0 - NEWAXEY(1)
+      NEWAXEY(-1) = -180.0 - NEWAXEY(2)
+      NEWAXEY(NJ+1) = 180.0 - NEWAXEY(NJ)
+      NEWAXEY(NJ+2) = 180.0 - NEWAXEY(NJ-1)
+cLT
+         WRITE(*,*) NEWAXEY(0 ), NEWAXEY(-1), NEWAXEY(NJ+1), 
+     $       NEWAXEY(NJ+2)
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE XPNAXEY(NEWAXEX,NEWAXEY,I1,I2,J1,J2,AX,AY,NI,NJ)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2,NI,NJ
+      REAL(kind=ip_realwp_p) NEWAXEX(NI)
+      REAL(kind=ip_realwp_p) NEWAXEY(NJ)
+      REAL(kind=ip_realwp_p) AX(NI)
+      REAL(kind=ip_realwp_p) AY(NJ)
+      INTEGER (kind=ip_intwp_p) I,J
+      DO 23000 I=1,NI
+         NEWAXEX(I) = AX(I)
+23000 CONTINUE 
+      DO 23002 J=1,NJ
+         NEWAXEY(J) = AY(J)
+23002 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE XPNCOF(I1,I2,J1,J2,NI,NJ,GRTYP,GRREF,IG1,IG2,IG3,
+     $IG4,SYM,AX,AY)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) I1,J1,I2,J2,NI,NJ,IG1,IG2,IG3,IG4
+      LOGICAL SYM
+      CHARACTER*1 GRTYP, GRREF
+      REAL(kind=ip_realwp_p) AX(NI),AY(NJ)
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      IF( (GRTYP.EQ.'L'.OR.GRTYP.EQ.'N'.OR.GRTYP.EQ.'S'.OR.GRTYP.EQ.
+     $'Y'))THEN
+         I1 = 1
+         I2 = NI
+         J1 = 1
+         J2 = NJ
+         RETURN
+      ENDIF 
+      IF ( (GRTYP .EQ. 'Z')) THEN
+         I1 = 0
+         I2 = NI + 2
+         J1 = -1
+         J2 = NJ + 2
+      ENDIF         
+      IF( (GRTYP.EQ.'A'.OR. GRTYP.EQ.'G'))THEN
+         I1 = 0
+         I2 = NI + 2
+         IF( (IG1.EQ.GLOBAL))THEN
+            J1 = -1
+            J2 = NJ + 2
+         ELSE 
+            IF( (IG1.EQ.NORD))THEN
+               J1 = -NJ - 1
+               J2 =  NJ + 2
+            ELSE 
+               J1 = -1
+               J2 =  2 * NJ + 2
+            ENDIF 
+         ENDIF 
+         RETURN
+      ENDIF 
+      IF( (GRTYP.EQ.'B'))THEN
+         I1 = 0
+         I2 = NI + 1
+         IF( (IG1.EQ.GLOBAL))THEN
+            J1 = 0
+            J2 = NJ + 1
+         ELSE 
+            IF( (IG1.EQ.NORD))THEN
+               J1 = -NJ + 1
+               J2 =  NJ + 1
+            ELSE 
+               J1 =  0
+               J2 =  2 * NJ
+            ENDIF 
+         ENDIF 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE XPNGD(ZOUT,I1,I2,J1,J2,ZI,NI,NJ,GRTYP,IG1,IG2,IG3,
+     $IG4,SYM,VECT)
+      USE mod_kinds_oasis
+      IMPLICIT NONE
+      INTEGER (kind=ip_intwp_p) GLOBAL, NORD, SUD, SUDNORD, NORDSUD
+      PARAMETER (GLOBAL = 0)
+      PARAMETER (NORD   = 1)
+      PARAMETER (SUD   = 2)
+      PARAMETER (SUDNORD= 0)
+      PARAMETER (NORDSUD= 1)
+      EXTERNAL PERMUT
+      INTEGER (kind=ip_intwp_p) I1,I2,J1,J2,NI,NJ
+      INTEGER (kind=ip_intwp_p) IG1, IG2, IG3, IG4
+      CHARACTER*1 GRTYP
+      INTEGER (kind=ip_intwp_p) I,J
+      REAL(kind=ip_realwp_p) ZOUT(I1:I2,J1:J2)
+      REAL(kind=ip_realwp_p) ZI(NI,NJ)
+      LOGICAL SYM,VECT
+      REAL(kind=ip_realwp_p) SIGN
+      IF( (VECT))THEN
+         SIGN = -1.0
+      ELSE 
+         SIGN = 1.0
+      ENDIF 
+      IF( (GRTYP.EQ. 'L'.OR. GRTYP.EQ. 'N'.OR. GRTYP.EQ. 'S'.OR.
+     $ GRTYP.EQ. 'Y'))THEN
+         DO 23004 J=1,NJ
+            DO 23006 I=1,NI
+               ZOUT(I,J) = ZI(I,J)
+23006       CONTINUE 
+23004    CONTINUE 
+         RETURN
+      ENDIF
+      IF( (GRTYP.EQ. 'Z') ) THEN
+          DO J=1,NJ
+            DO I=1,NI
+              ZOUT(I,J) = ZI(I,J)
+            END DO 
+          END DO
+          DO J=1,NJ
+            ZOUT(0,J) = ZI(NI,J)
+            ZOUT(NI+1,J) = ZOUT(1,J)
+            ZOUT(NI+2,J) = ZOUT(2,J)
+          END DO 
+          DO I=0,NI/2
+            ZOUT(I,0) = SIGN * ZOUT(I+NI/2, 1)
+            ZOUT(I,-1)= SIGN * ZOUT(I+NI/2, 2)
+            ZOUT(I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+            ZOUT(I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+            ZOUT(I+NI/2,0) = SIGN * ZOUT(I, 1)
+            ZOUT(I+NI/2,-1)= SIGN * ZOUT(I, 2)
+            ZOUT(I+NI/2,NJ+1)=SIGN * ZOUT(I, NJ)
+            ZOUT(I+NI/2,NJ+2)=SIGN * ZOUT(I, NJ-1)
+          END DO 
+          DO I=1,2
+            ZOUT(NI+I,0) = SIGN * ZOUT(NI/2+I,1)
+            ZOUT(NI+I,-1)= SIGN * ZOUT(I+NI/2, 2)
+            ZOUT(NI+I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+            ZOUT(NI+I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+          END DO 
+      ENDIF
+      IF( (GRTYP.EQ.'A'.OR. GRTYP.EQ.'G'))THEN
+         IF( (IG2.EQ. NORDSUD))THEN
+            CALL PERMUT(ZI, NI, NJ)
+         ENDIF 
+         DO 23012 J=1,NJ
+            DO 23014 I=1,NI
+               ZOUT(I,J) = ZI(I,J)
+23014       CONTINUE 
+23012    CONTINUE 
+         DO 23016 J=1,NJ
+            ZOUT(0,J) = ZI(NI,J)
+            ZOUT(NI+1,J) = ZOUT(1,J)
+            ZOUT(NI+2,J) = ZOUT(2,J)
+23016    CONTINUE 
+         IF( (IG1.EQ. GLOBAL))THEN
+            DO 23020 I=0,NI/2
+               ZOUT(I,0) = SIGN * ZOUT(I+NI/2, 1)
+               ZOUT(I,-1)= SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+               ZOUT(I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+               ZOUT(I+NI/2,0) = SIGN * ZOUT(I, 1)
+               ZOUT(I+NI/2,-1)= SIGN * ZOUT(I, 2)
+               ZOUT(I+NI/2,NJ+1)=SIGN * ZOUT(I, NJ)
+               ZOUT(I+NI/2,NJ+2)=SIGN * ZOUT(I, NJ-1)
+23020       CONTINUE 
+            DO 23022 I=1,2
+               ZOUT(NI+I,0) = SIGN * ZOUT(NI/2+I,1)
+               ZOUT(NI+I,-1)= SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(NI+I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+               ZOUT(NI+I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+23022       CONTINUE 
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            IF( (SYM))THEN
+               DO 23028 J=-NJ+1, 0
+                  DO 23030 I=0,NI+2
+                     ZOUT(I,J) = ZOUT(I, -J+1)
+23030             CONTINUE 
+23028          CONTINUE 
+            ELSE 
+               DO 23032 J=-NJ+1, 0
+                  DO 23034 I=0,NI+2
+                     ZOUT(I,J) = -ZOUT(I, -J+1)
+23034             CONTINUE 
+23032          CONTINUE 
+            ENDIF 
+            DO 23036 I=0,NI/2
+               ZOUT(I,-NJ) = SIGN * ZOUT(I+NI/2, -NJ+1)
+               ZOUT(I,-NJ-1)= SIGN * ZOUT(I+NI/2,-NJ+2)
+               ZOUT(I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+               ZOUT(I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+               ZOUT(I+NI/2,-NJ) = SIGN * ZOUT(I, -NJ+1)
+               ZOUT(I+NI/2,-NJ-1)= SIGN * ZOUT(I, -NJ+2)
+               ZOUT(I+NI/2,NJ+1)=SIGN * ZOUT(I, NJ)
+               ZOUT(I+NI/2,NJ+2)=SIGN * ZOUT(I, NJ-1)
+23036       CONTINUE 
+            DO 23038 I=1,2
+               ZOUT(NI+I,-NJ) = SIGN * ZOUT(NI/2+I,-NJ+1)
+               ZOUT(NI+I,-NJ-1)= SIGN * ZOUT(I+NI/2, -NJ+2)
+               ZOUT(NI+I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ)
+               ZOUT(NI+I,NJ+2)=SIGN * ZOUT(I+NI/2, NJ-1)
+
+23038       CONTINUE 
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            IF( (SYM))THEN
+               DO 23044 J=1,NJ
+                  DO 23046 I=0,NI+2
+                     ZOUT(I,NJ+J) = ZOUT(I, NJ-J+1)
+23046             CONTINUE 
+23044          CONTINUE 
+            ELSE 
+               DO 23048 J=1,NJ
+                  DO 23050 I=0,NI+2
+                     ZOUT(I,NJ+J) = -ZOUT(I,NJ-J+1)
+23050             CONTINUE 
+23048          CONTINUE 
+            ENDIF 
+            DO 23052 I=0,NI/2
+               ZOUT(I,0) = SIGN * ZOUT(I+NI/2, 1)
+               ZOUT(I,-1)= SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(I,2*NJ+1)=SIGN * ZOUT(I+NI/2, 2*NJ)
+               ZOUT(I,2*NJ+2)=SIGN * ZOUT(I+NI/2, 2*NJ-1)
+               ZOUT(I+NI/2,0) = SIGN * ZOUT(I, 1)
+               ZOUT(I+NI/2,-1)= SIGN * ZOUT(I,2)
+               ZOUT(I+NI/2,2*NJ+1)=SIGN * ZOUT(I, 2*NJ)
+               ZOUT(I+NI/2,2*NJ+2)=SIGN * ZOUT(I, 2*NJ-1)
+23052       CONTINUE 
+            DO 23054 I=1,2
+               ZOUT(NI+I,0) = SIGN * ZOUT(NI/2+I,1)
+               ZOUT(NI+I,1)= SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(NI+I,2*NJ+1)=SIGN * ZOUT(I+NI/2, 2*NJ)
+               ZOUT(NI+I,2*NJ+2)=SIGN * ZOUT(I+NI/2, 2*NJ-1)
+23054       CONTINUE 
+         ENDIF 
+      ENDIF 
+      IF( (GRTYP.EQ.'B'))THEN
+         IF( (IG2.EQ. NORDSUD))THEN
+            CALL PERMUT(ZI, NI, NJ)
+         ENDIF 
+         DO 23060 J=1,NJ
+            DO 23062 I=1,NI
+               ZOUT(I,J) = ZI(I,J)
+23062       CONTINUE 
+23060    CONTINUE 
+         DO 23064 J=1,NJ
+            ZOUT(0,J) = ZI(NI-1,J)
+            ZOUT(NI+1,J) = ZOUT(2,J)
+23064    CONTINUE 
+         IF( (IG1.EQ. GLOBAL))THEN
+            DO 23068 I=0,NI/2+1
+               ZOUT(I,0) = SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ-1)
+               ZOUT(I+NI/2,0) = SIGN * ZOUT(I, 2)
+               ZOUT(I+NI/2,NJ+1)=SIGN * ZOUT(I, NJ-1)
+23068       CONTINUE 
+            ZOUT(NI+1,0) = SIGN * ZOUT(NI/2+1,2)
+            ZOUT(NI+1,NJ+1)=SIGN * ZOUT(NI/2+1, NJ-1)
+         ENDIF 
+         IF( (IG1.EQ. NORD))THEN
+            IF( (SYM))THEN
+               DO 23074 J=-NJ+2, 0
+                  DO 23076 I=0,NI+1
+                     ZOUT(I,J) = ZOUT(I, -J+2)
+23076             CONTINUE 
+23074          CONTINUE 
+            ELSE 
+               DO 23078 J=-NJ+2, 0
+                  DO 23080 I=0,NI+1
+                     ZOUT(I,J) = -ZOUT(I, -J+2)
+23080             CONTINUE 
+23078          CONTINUE 
+            ENDIF 
+            DO 23082 I=0,NI/2+1
+               ZOUT(I,-NJ+1) = SIGN * ZOUT(I+NI/2, -NJ+3)
+               ZOUT(I,NJ+1)=SIGN * ZOUT(I+NI/2, NJ-1)
+               ZOUT(I+NI/2,-NJ+1) = SIGN * ZOUT(I, -NJ+3)
+               ZOUT(I+NI/2,NJ+1)=SIGN * ZOUT(I, NJ-1)
+23082       CONTINUE 
+            ZOUT(NI+1,-NJ+1) = SIGN * ZOUT(NI/2+1,-NJ+3)
+            ZOUT(NI+1,NJ+1)=SIGN * ZOUT(1+NI/2, NJ-1)
+         ENDIF 
+         IF( (IG1.EQ. SUD))THEN
+            IF( (SYM))THEN
+               DO 23088 J=1,NJ-1
+                  DO 23090 I=0,NI+1
+                     ZOUT(I,NJ+J) = ZOUT(I, NJ-J)
+23090             CONTINUE 
+23088          CONTINUE 
+            ELSE 
+               DO 23092 J=1,NJ-1
+                  DO 23094 I=0,NI+1
+                     ZOUT(I,NJ+J) = -ZOUT(I,NJ-J)
+23094             CONTINUE 
+23092          CONTINUE 
+            ENDIF 
+            DO 23096 I=0,NI/2+1
+               ZOUT(I,0) = SIGN * ZOUT(I+NI/2, 2)
+               ZOUT(I,2*NJ)=SIGN * ZOUT(I+NI/2, 2*NJ-2)
+               ZOUT(I+NI/2,0) = SIGN * ZOUT(I, 2)
+               ZOUT(I+NI/2,2*NJ)=SIGN * ZOUT(I, 2*NJ-2)
+23096       CONTINUE 
+            ZOUT(NI+1,0) = SIGN * ZOUT(NI/2+1,2)
+            ZOUT(NI+1,2*NJ)=SIGN * ZOUT(1+NI/2, 2*NJ-2)
+         ENDIF 
+      ENDIF 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE LLFXY(DLAT,DLON,X,Y,D60,DGRW,NHEM) 
+      USE mod_kinds_oasis
+C
+C AUTHOR   - J.D. HENDERSON  -  FEB 75
+C 
+C OBJECT(LLFXY)
+C         - COMPUTES LATITUDE AND LONGITUDE OF A POINT IN A POLAR
+C           STEREOGRAPHIC GRID FROM CO-ORDINATES IN THE GRID MEASURED
+C           FROM THE POLE.
+C
+C USAGE    - CALL LLFXY(DLAT,DLON,X,Y,D60,DGRW,NHEM)
+C
+C ARGUMENTS
+C   OUT   - DLAT - LATITUDE IN DEGREES (-90 TO +90, POSITIVE N).
+C         - DLON - LONGITUDE IN DEGREES (-180 TO +180, POSITIVE E).
+C   IN    - X    - X-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C         - Y    - Y-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN
+C         - D60  - GRID LENGTH (IN METRES) OF THE POLAR STEREOGRAPHIC
+C                  GRID AT 60 DEGREES
+C         - DGRW - ORIENTATION OF GREENWICH MERIDIAN WITH RESPECT TO
+C                  THE GRID (IN DEGREES)
+C         - NHEM - 1 FOR NORTHERN HEMISPHERE
+C                  2 FOR SOUTHERN HEMISPHERE 
+C
+C NOTES    - THE COMPANION ROUTINE XYFLL, WHICH COMPUTES THE GRID
+C           CO-ORDINATES GIVEN THE LATITUDE AND LONGITUDE, IS ALSO
+C           AVAILABLE.
+C
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.
+C     * RDTODG = 180/PIE, DGTORD = PIE/180                                     
+C
+      DATA PIE    /3.14159265358979323846/
+      DATA RDTODG /57.295779513082/
+      DATA DGTORD /1.7453292519943E-2/
+C* ------------------------------------------------------------------------
+      RE=1.866025*6.371E+6/D60 
+      RE2=RE**2
+C     * IF POINT IS AT POLE SET COORD TO (0.,90.). 
+      DLAT=90.                 
+      DLON=0.
+      IF(X.EQ.0. .AND. Y.EQ.0.) GO TO 39
+C                                                 
+C     * CALCULATE LONGITUDE IN MAP COORDINATES.
+C
+      IF(X.EQ.0.) DLON=SIGN(90.,Y)
+      IF(X.NE.0.) DLON=ATAN(Y/X)*RDTODG
+      IF(X.LT.0.) DLON=DLON+SIGN(180.,Y)
+C                  
+C     * ADJUST LONGITUDE FOR GRID ORIENTATION. 
+C   
+      DLON=DLON-DGRW 
+      IF(DLON.GT.+180.) DLON=DLON-360.
+      IF(DLON.LT.-180.) DLON=DLON+360. 
+C              
+C     * CALCULATE LATITUDE. 
+C                 
+      R2=X**2+Y**2
+      DLAT=(RE2-R2)/(RE2+R2) 
+      DLAT= ASIN(DLAT)*RDTODG 
+C   
+C     * CHANGE SIGNS IF IN SOUTHERN HEMISPHERE.
+C
+   39 IF(NHEM.EQ.2) DLAT=-DLAT
+      IF(NHEM.EQ.2) DLON=-DLON 
+C 
+      RETURN
+      END 
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%   
+C 
+      SUBROUTINE XYFLL(X,Y,DLAT,DLON,D60,DGRW,NHEM)
+      USE mod_kinds_oasis
+C  
+C AUTHOR   - J.D. HENDERSON  -  FEB 75
+C    
+C OBJECT(XYFLL) 
+C         - COMPUTES THE GRID CO-ORDINATES MEASURED FROM THE POLE OF A 
+C           POINT, GIVEN THE LATITUDE AND LONGITUDE IN DEGREES.
+C                                                                              
+C USAGE    - CALL XYFLL(X,Y,DLAT,DLON,D60,DGRW,NHEM) 
+C             
+C ARGUMENTS   
+C   OUT   - X    - X-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE 
+C                  AS ORIGIN    
+C                  AS ORIGIN
+C         - Y    - Y-CO-ORDINATE OF THE POINT AS MEASURED WITH POLE
+C                  AS ORIGIN      
+C   IN    - DLAT - LATITUDE IN DEGREES (-90 TO +90, POSITIVE N) 
+C         - DLON - LONGITUDE IN DEGREES (-180 TO +180, POSITIVE E) 
+C         - D60  - GRID LENGTH (IN METRES) OF THE POLAR STEREOGRAPHIC  
+C                  GRID AT 60 DEGREES
+C         - DGRW - ORIENTATION OF GREENWICH MERIDIAN WITH RESPECT TO 
+C                  THE GRID (IN DEGREES)      
+C         - NHEM - 1 FOR NORTHERN HEMISPHERE    
+C                  2 FOR SOUTHERN HEMISPHERE  
+C 
+C NOTES    - THE COMPANION ROUTINE LLFXY, WHICH COMPUTES THE LATITUDE   
+C           AND LONGITUDE GIVEN THE GRID-COORDINATES, IS ALSO AVAILABLE.
+C                                                                
+C---------------------------------------------------------------------------
+C                                                     
+C     * 1.866025=(1+SIN60),   6.371E+6=EARTH RADIUS IN METERS.    
+C      
+C RDTODG = 180/PIE, DGTORD = PIE/180    
+      DATA PIE    /3.14159265358979323846/       
+      DATA RDTODG /57.295779513082/ 
+      DATA DGTORD /1.7453292519943E-2/  
+C 
+      RE=1.866025*6.371E+6/D60    
+C   
+      GLON=DLON  
+      IF(NHEM.EQ.2) GLON=-DLON  
+      GLAT=DLAT     
+      IF(NHEM.EQ.2) GLAT=-DLAT   
+C    
+      RLON=DGTORD*(GLON+DGRW)      
+      RLAT=DGTORD*GLAT   
+      SINLAT=SIN(RLAT)    
+      R=RE*SQRT((1.-SINLAT)/(1.+SINLAT)) 
+      X=R*COS(RLON)        
+      Y=R*SIN(RLON)                                                            
+C                                                                              
+      RETURN                                              
+      END                                  
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE ORDLEG(SBX,COA,IR) 
+      USE mod_kinds_oasis
+C     
+C AUTEUR   - D. ROBERTSON 
+C  
+C OBJET(ORDLEG)   
+C         - THIS ROUTINE IS A SUBSET OF BELOUSOVS ALGORITHM  
+C           USED TO CALCULATE ORDINARY LEGENDRE POLYNOMIALS.  
+C                                        
+C USAGE    - CALL ORDLEG(SBX,COA,IR)
+C   
+C ARGUMENTS        
+C   OUT   - SBX  - LEGENDRE POLYNOMIAL EVALUATED AT COA        
+C   IN    - COA - COSINE OF COLATITUDE   
+C   IN    - IR  - WAVE NUMBER  
+C                                         
+C* -------------------------------------------------------------------------
+C               
+C              
+C RDTODG = 180/PIE, DGTORD = PIE/180     
+      DATA PIE    /3.14159265358979323846/ 
+      DATA RDTODG /57.295779513082/   
+      DATA DGTORD /1.7453292519943E-2/    
+C      
+      PI = PIE                        
+      SQR2=SQRT(2.)                  
+      IRPP = IR + 1      
+      IRPPM = IRPP - 1  
+      DELTA =   ACOS(COA)  
+      SIA =  SIN(DELTA)   
+C                              
+      THETA=DELTA           
+      C1=SQR2    
+C                                     
+      DO 20 N=1,IRPPM                              
+      FN=FLOAT(N)                           
+      FN2=2.*FN                             
+      FN2SQ=FN2*FN2                  
+      C1=C1* SQRT(1.0-1.0/FN2SQ)     
+   20 CONTINUE                        
+C             
+      N=IRPPM              
+      ANG=FN*THETA                            
+      S1=0.0                    
+      C4=1.0                                          
+      A=-1.0                               
+      B=0.0                                       
+      N1=N+1          
+C                        
+      DO 27 KK=1,N1,2                 
+      K=KK-1                   
+      IF (K.EQ.N) C4=0.5*C4           
+      S1=S1+C4* COS(ANG)         
+      A=A+2.0        
+      B=B+1.0         
+      FK=FLOAT(K)      
+      ANG=THETA*(FN-FK-2.0)      
+      C4=(A*(FN-B+1.0)/(B*(FN2-A)))*C4  
+   27 CONTINUE   
+C                               
+      SBX=S1*C1                                  
+C       
+      RETURN     
+      END 
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      LOGICAL FUNCTION VALIDE(NOM, ICHK, MIN, MAX)
+C
+C AUTEUR   - P. SARRAZIN  - AVRIL 82
+C
+C OBJET(VALIDE)
+C         - VERIFIER SI ICHK => MIN OU =< MAX
+C         - MESSAGE SI ICHK N'EST PAS DANS LES LIMITES
+C
+C ARGUMENTS
+C   IN    - NOM   - NOM DE LA VARIABLE EMPLOYE PAR LA ROUTINE
+C   IN    - ICHK  - VALEUR DE LA VARIABLE POUR VERIFICATION
+C   IN    - MIN   - VALEUR MINIMUM DE ICHK
+C   IN    - MAX   - VALEUR MAXIMUM DE ICHK
+C
+C MODULES - SCINT - UVINT
+C
+C* ----------------------------------------------------------------------
+      IF( (ICHK.LT.MIN .OR. ICHK.GT.MAX))THEN
+         WRITE(6,600) NOM,ICHK,MIN,MAX
+      ENDIF 
+600   FORMAT("Bad value for",I10,"VALEUR=",I10,"MINIMUM=",
+     $   I10,"MAXIMUM=",I10)
+      VALIDE = (ICHK.GE.MIN) .AND. (ICHK.LE.MAX)
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE PERMUT(Z,NI,NJ)
+      USE mod_kinds_oasis
+      REAL(kind=ip_realwp_p) Z(NI,NJ)
+C
+C AUTEUR   - M. VALIN  -  FEV 82
+C
+C OBJET(PERMUT)
+C         - ROTATION D'UNE MATRICE AUTOUR DE LA LIGNE DU MILIEU.
+C           CETTE ROUTINE EST UTILISEE POUR RE=ARRANGER LES
+C           DONNEES DANS UN CHAMP. EX: POUR CONTOURER, ON A
+C           DES DONNEES DANS L'ORDRE SUIVANT, DU SUD AU NORD
+C           ALORS QUE POUR L'INTERPOLATION ELLES DOIVENT ETRE
+C           ETALEES DU NORD AU SUD.
+C
+C APPEL    - CALL PERMUT(Z,NI,NJ)
+C
+C ARGUMENTS
+C IN/OUT  - Z  - CHAMP QUI SUBIT LA ROTATION
+C   IN    - NI - PREMIERE DIMENSION DE Z
+C   IN    - NJ - DEUXIEME DIMENSION DE Z
+C* -----------------------------------------------------------------------
+C
+      NCC = NJ/2
+      DO 23000 J=1,NCC
+         DO 23002 I=1,NI
+            T = Z(I,NJ+1-J)
+            Z(I,NJ+1-J) = Z(I,J)
+            Z(I,J) = T
+23002    CONTINUE 
+23000 CONTINUE 
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
+C    
+      SUBROUTINE CIGAXG(CGTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+      USE mod_kinds_oasis
+      CHARACTER*1 CGTYP
+C
+C AUTEUR   - M. VALIN  -  FEV 82
+C
+C
+C OBJET(CIGAXG)
+C         - PASSE DES PARAMETRES (ENTIERS) DESCRIPTEURS DE GRILLE
+C           AUX PARAMETRES REELS.
+C
+C APPEL    - CALL IGAXG(CGTYP,XG1,XG2,XG3,XG4,IG1,IG2,IG3,IG4)
+C
+C ARGUMENTS
+C   IN    - CGTYP - TYPE DE GRILLE (VOIR OUVRIR)
+C   OUT   - XG1   - ** DESCRIPTEUR DE GRILLE (REEL),
+C   OUT   - XG2   -    IGTYP = 'N', PI, PJ, D60, DGRW
+C   OUT   - XG3   -    IGTYP = 'L', LAT0, LON0, DLAT, DLON,
+C   OUT   - XG4   -    IGTYP = 'A', 'B', 'G', XG1 = 0. GLOBAL,
+C                                                 = 1. NORD
+C                                                 = 2. SUD **
+C   IN    - IG1   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   IN    - IG2   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   IN    - IG3   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   IN    - IG4   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C
+CMESSAGES - "ERREUR, MAUVAISE SPECIFICATION DE GRILLE, (TYPE) (IGAXG)"
+C
+C-------------------------------------------------------------------
+C
+
+      IF( ((CGTYP.EQ. 'N') .OR. (CGTYP.EQ.'S')))THEN
+         IF((IG4.LT. 32768))THEN
+            XG1 = IG2 * 0.1
+            XG2 = IG1 * 0.1
+            XG3 = IG4 * 100.
+            XG4 = IG3 * 0.01
+         ELSE 
+            JG3 = IG3
+            JG4 = IG4
+            JG4 = JG4 - 32768
+            XG3 = IG1 * 100.
+            IF((IG3 .GT. 32767))THEN
+               XG3 = XG3 * 10.
+               JG3 = JG3 - 32768
+            ENDIF 
+            XG4 = IG2 * .1
+            IF((JG4.GT. 16383))THEN
+               XG4 = 360. - XG4
+               JG4 = JG4 - 16384
+            ENDIF 
+            DLAT = 90. -(JG4*180./16383.)
+            DLON = (JG3*360./32767.)
+            IHEM = 1
+            IF(('S'.EQ.CGTYP))THEN
+               IHEM = 2
+            ENDIF 
+            CALL XYFLL(XG1,XG2,DLAT,DLON,XG3,XG4,IHEM)
+            XG1 = 1.0 - XG1
+            XG2 = 1.0 - XG2
+         ENDIF 
+      ELSE 
+         IF((CGTYP.EQ. 'C'))THEN
+            XG1 = IG3 * 0.01 - 90.
+            XG2 = IG4 * 0.01
+            XG3 = 180. / IG1
+            XG4 = 360. / IG2
+         ELSE 
+            IF( ((CGTYP.EQ. 'A') .OR. (CGTYP.EQ. 'B') .OR.   (CGTYP
+     $      .EQ. 'G')))THEN
+               XG1 = IG1
+               XG2 = IG2
+               XG3 = 0.
+               XG4 = 0.
+            ELSE 
+               IF((CGTYP.EQ. 'L'))THEN
+                  XG1 = IG3 * 0.01 - 90.
+                  XG2 = IG4 * 0.01
+                  XG3 = IG1 * 0.01
+                  XG4 = IG2 * 0.01
+               ELSE 
+                  IF((CGTYP.EQ. 'H'))THEN
+                     XG1 = IG3
+                     XG2 = .01*IG4 - 90.
+                     XG3 = 500*IG2
+                     XG4 = IG1*.2
+                  ELSE 
+                     WRITE(6,600)
+                  ENDIF 
+               ENDIF 
+            ENDIF 
+         ENDIF 
+      ENDIF 
+600   FORMAT(' Error bad grid specification , (TYPE)'
+     $,'(IGAXG)')
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      SUBROUTINE CXGAIG(CGTYP,IG1,IG2,IG3,IG4,XG1,XG2,XG3,XG4)
+      USE mod_kinds_oasis
+      LOGICAL VALIDE
+      EXTERNAL VALIDE
+      CHARACTER * 1 CGTYP
+      LOGICAL LFLAG
+C
+C AUTEUR   - M. VALIN  -  FEV 82
+C
+C OBJET(XGAIG)
+C         - PASSE DES PARAMETRES (REELS) DESCRIPTEURS DE GRILLE
+C           AUX PARAMETRES ENTIERS.
+C
+C APPEL    - CALL XGAIG(CGTYP,IG1,IG2,IG3,IG4,XG1,XG2,XG3,XG4)
+C
+C ARGUMENTS
+C   IN    - CGTYP - TYPE DE GRILLE (VOIR OUVRIR)
+C   OUT   - IG1   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   OUT   - IG2   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   OUT   - IG3   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   OUT   - IG4   - DESCRIPTEUR DE GRILLE (ENTIER) VOIR OUVRIR
+C   IN    - XG1   - ** DESCRIPTEUR DE GRILLE (REEL),
+C   IN    - XG2   -    IGTYP = 'N', PI, PJ, D60, DGRW
+C   IN    - XG3   -    IGTYP = 'L', LAT0, LON0, DLAT, DLON,
+C   IN    - XG4   -    IGTYP = 'A', 'B', 'G', XG1 = 0, GLOBAL
+C                                                 = 1, NORD
+C                                                 = 2, SUD **
+C
+C MESSAGES - "ERREUR DANS LA DESCRIPTION DE LA GRILLE (IG1) (XGAIG)"
+C           "ERREUR, MAUVAISE SPECIFICATION (LAT0) (XGAIG)"
+C           "ERREUR, GRILLE INCONNUE (TYPE) (XGAIG)"
+C
+C* ------------------------------------------------------------------
+C
+C
+      IF( (CGTYP.EQ. 'N' .OR. CGTYP.EQ.'S'))THEN
+         IG1 = NINT(XG2 * 10.)
+         IG2 = NINT(XG1 * 10.)
+         IG3 = NINT(XG4 * 100.)
+         IG4 = NINT(XG3 * 0.01)
+23002    IF( (IG3.LT. 0))THEN
+            IG3 = IG3 + 36000
+            GOTO 23002
+         ENDIF 
+         IF((IG1.LT.0.OR.IG2.LT.0.OR.IG1.GT.2047.OR.IG2.GT.2047.OR.
+     $   IG4.GT.32000))THEN
+            IG1 = 0
+            IG2 = 0
+            IG3 = 0
+            IG4 = 32768
+            IF((XG3.GT. 204700))THEN
+               IG3 = 32768
+               IG1 = NINT(XG3*.001)
+            ELSE 
+               IG3 = 0
+               IG1 = NINT(XG3*.01)
+            ENDIF 
+            IG2 = NINT(XG4*10)
+            IF((IG2.LT.0))THEN
+               IG2 = ABS(IG2)
+               IG4 = IG4 + 16384
+            ENDIF 
+            IF((IG2.GT.1800))THEN
+               IG2 = ABS(IG2 - 3600)
+               IG4 = IG4 + 16384
+            ENDIF 
+            IHEM = 1
+            IF(('S'.EQ.CGTYP))THEN
+               IHEM = 2
+            ENDIF 
+            CALL LLFXY(DLAT,DLON,1.-XG1,1.-XG2,XG3,XG4,IHEM)
+            DLAT = 90. - DLAT
+            IF((DLON.LT.0))THEN
+               DLON = DLON + 360.
+            ENDIF 
+            IG3 = IG3 + NINT(DLON*32767./360.)
+            IG4 = IG4 + NINT(DLAT*16383./180.)
+         ENDIF 
+      ELSE 
+         IF( (CGTYP.EQ. 'A' .OR. CGTYP.EQ. 'B' .OR.   CGTYP.EQ. 'G')
+     $   )THEN
+            IG1 = XG1
+            IG2 = XG2
+            IG3 = 0
+            IG4 = 0
+            LFLAG=VALIDE("IG1",IG1,0,2)
+            LFLAG=VALIDE("IG2",IG2,0,1)
+         ELSE 
+            IF((CGTYP.EQ. 'C'))THEN
+               IG1 = 180. / XG3 + 0.5
+               IG2 = 360. / XG4 + 0.5
+               IG3 = (90. + XG1) * 100. + 0.5
+               IG4 = XG2 * 100. + 0.5
+23020          IF( (IG4.LT. 0))THEN
+                  IG4 = IG4 + 36000
+                  GOTO 23020
+               ENDIF 
+               IF( (IG3.LT. 0))THEN
+                  WRITE(6,601)
+               ENDIF 
+            ELSE 
+               IF( (CGTYP.EQ. 'H'))THEN
+                  IG1 = NINT(5.*XG4)
+23026             IF( (IG1.LT. 0))THEN
+                     IG1 = IG1 + 1800
+                     GOTO 23026
+                  ENDIF 
+                  IG2 = NINT(.002*XG3)
+                  IG3 = NINT(XG1)
+                  IG4 = NINT(100.*(90.+XG2))
+               ELSE 
+                  IF( (CGTYP.EQ. 'L'))THEN
+                     IG1 = XG3 * 100. + 0.5
+                     IG2 = XG4 * 100. + 0.5
+                     IG3 = (90. + XG1) * 100. + 0.5
+                     IG4 = XG2 * 100. + 0.5
+23030                IF( (IG4.LT. 0))THEN
+                        IG4 = IG4 + 36000
+                        GOTO 23030
+                     ENDIF 
+                     IF( (IG3.LT. 0))THEN
+                        WRITE(6,601)
+                     ENDIF 
+                  ELSE 
+                     WRITE(6,602)
+                  ENDIF 
+               ENDIF 
+            ENDIF 
+         ENDIF 
+      ENDIF 
+601   FORMAT(' Error, bad specification (LAT0) (XGAIG)')
+602   FORMAT(' Error, unknown grid (TYPE) (XGAIG)')
+      RETURN
+      END
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Index: CPL/oasis3/trunk/src/lib/fscint/src/memoir.f
===================================================================
--- CPL/oasis3/trunk/src/lib/fscint/src/memoir.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/fscint/src/memoir.f	(revision 1677)
@@ -0,0 +1,168 @@
+      MODULE memoir
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *memoir*  - F90 interface for dynamic allocation in FSCINT
+C
+C     Purpose:
+C     -------
+C     Handle dynamic allocation in FSCINT
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *memoir(r-i)(pw,koff,ksize,koldsize)
+C
+C     Input:
+C     -----
+C                pw       : array to be allocated
+C                ksize    : new size to be allocated 
+C                koldsize : old size of allocation
+C
+C     Output:
+C     ------
+C                koff     : status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     This F90 module handles dynamic allocation within FSCINT.
+C     It deals with both INTEGER and REAL memory allocation.
+C     It has been tested on a variety of platforms (SGI, VPP, T3E, C90)
+C     and is truly portable. The compilation step may vary across
+C     platforms (see OASIS documentation 2.2). The module has been
+C     written with fixed format and should then be named with suffix .f
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       A. Piacentini  97/09/15  Created
+C       2.3       A. Piacentini  98/10/01  Modified: Bug corrected in case
+C                                          of reallocation
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C* ------------------------------------------------------------------
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* Block interface
+C
+          INTERFACE memoirh
+             MODULE PROCEDURE memoirr,memoiri
+          END INTERFACE
+C
+      CONTAINS
+C
+C* Real allocation
+C
+      SUBROUTINE memoirr(pw,koff,ksize,koldsize)
+C
+      USE mod_kinds_oasis
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER  :: pw
+      INTEGER (kind=ip_intwp_p)                      :: koff
+      INTEGER (kind=ip_intwp_p)                      :: ksize
+      INTEGER (kind=ip_intwp_p)                      :: koldsize
+C
+      REAL(kind=ip_realwp_p), DIMENSION(:), POINTER  :: aw
+      INTEGER (kind=ip_intwp_p)                      :: ierr
+C
+C      PRINT *,'memoirR ksize ',ksize
+C
+      IF (ksize > 0) THEN
+          IF (koldsize > 0) THEN
+              allocate(aw(ksize),stat=ierr)
+C              PRINT *,'ierr= ',ierr
+              IF(.NOT. associated(aw)) PRINT *,'memoirR Something Wrong'
+              koff=1
+              aw(1:koldsize)=pw
+              deallocate(pw,stat=ierr)
+C              PRINT *,'memoirR dealloc of old pw ierr= ',ierr
+              pw=>aw
+          ELSE   
+              allocate(pw(ksize),stat=ierr)
+C              PRINT *,'ierr= ',ierr
+              IF(.NOT. associated(pw)) PRINT *,'memoirR Something Wrong'
+C
+C             PRINT *,'memoirR allocated'
+C
+              koff=1
+          ENDIF 
+      ELSE
+          IF(associated(pw)) THEN
+              deallocate(pw,stat=ierr)
+C              PRINT *,'memoirR dealloc ierr= ',ierr
+          ELSE
+              STOP 'error in memoirR deallocation'
+          END IF
+C
+C          PRINT *,'memoirR deallocated'
+C
+      ENDIF
+C
+      END SUBROUTINE memoirr
+C
+C* Integer allocation 
+C
+      SUBROUTINE memoiri(kw,koff,ksize,koldsize)
+C
+      USE mod_kinds_oasis
+      INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER  :: kw
+      INTEGER (kind=ip_intwp_p)                      :: koff
+      INTEGER (kind=ip_intwp_p)                      :: ksize
+      INTEGER (kind=ip_intwp_p)                      :: koldsize
+C
+      INTEGER (kind=ip_intwp_p) , DIMENSION(:), POINTER  :: iw
+      INTEGER (kind=ip_intwp_p)                      :: ierr
+C
+C      PRINT *,'memoirI ksize ',ksize
+C
+      IF (ksize > 0) THEN
+          IF (koldsize > 0) THEN
+              allocate(iw(ksize),stat=ierr)
+C              PRINT *,'ierr= ',ierr
+              IF(.NOT. associated(iw)) PRINT *,'memoirI Something Wrong'
+              koff=1
+              iw(1:koldsize)=kw
+              deallocate(kw,stat=ierr)
+C              PRINT *,'memoirI dealloc of old kw ierr= ',ierr
+              kw=>iw
+          ELSE   
+              allocate(kw(ksize),stat=ierr)
+C              PRINT *,'ierr= ',ierr
+              IF(.NOT. associated(kw)) PRINT *,'memoirI Something Wrong'
+C
+C             PRINT *,'memoirI allocated'
+C
+              koff=1
+          ENDIF 
+      ELSE
+          IF(associated(kw)) THEN
+              deallocate(kw,stat=ierr)
+C              PRINT *,'memoirI dealloc ierr= ',ierr
+          ELSE
+              STOP 'error in memoirI deallocation'
+          END IF
+C
+C          PRINT *,'memoirI deallocated'
+C
+      ENDIF
+C
+      END SUBROUTINE memoiri
+C
+      END MODULE memoir
+
+
+
+
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum.h	(revision 1677)
@@ -0,0 +1,11 @@
+    function MPP_CHKSUM_( var, pelist )
+!mold is a dummy array to be used by TRANSFER()
+!must be same TYPE as result
+!result is LONG_KIND, which will actually be int ifdef no_8byte_integers
+      integer(LONG_KIND) :: MPP_CHKSUM_, mold(1)
+      MPP_TYPE_, intent(in) :: var MPP_RANK_
+      integer, intent(in), optional :: pelist(:)
+
+      MPP_CHKSUM_ = mpp_chksum( TRANSFER(var,mold), pelist )
+      return
+    end function MPP_CHKSUM_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum_int.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum_int.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_chksum_int.h	(revision 1677)
@@ -0,0 +1,8 @@
+    function MPP_CHKSUM_INT_( var, pelist )
+      MPP_TYPE_ :: MPP_CHKSUM_INT_
+      MPP_TYPE_, intent(in) :: var MPP_RANK_
+      integer, optional :: pelist(:)
+      MPP_CHKSUM_INT_ = sum(var)
+      call mpp_sum( MPP_CHKSUM_INT_, pelist )
+      return
+    end function MPP_CHKSUM_INT_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_field.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_field.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_field.h	(revision 1677)
@@ -0,0 +1,224 @@
+    subroutine MPP_GLOBAL_FIELD_2D_( domain, local, global, flags )
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(in)  ::  local(:,:)
+      MPP_TYPE_, intent(out) :: global(:,:)
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: local3D (size( local,1),size( local,2),1)
+      MPP_TYPE_ :: global3D(size(global,1),size(global,2),1)
+#ifdef use_CRI_pointers
+      pointer( lptr,  local3D )
+      pointer( gptr, global3D )
+      lptr = LOC( local)
+      gptr = LOC(global)
+      call mpp_global_field( domain, local3D, global3D, flags )
+#else
+      local3D = RESHAPE( local, SHAPE(local3D) )
+      call mpp_global_field( domain, local3D, global3D, flags )
+      global = RESHAPE( global3D, SHAPE(global) )
+#endif
+    end subroutine MPP_GLOBAL_FIELD_2D_
+
+    subroutine MPP_GLOBAL_FIELD_3D_( domain, local, global, flags )
+!get a global field from a local field
+!local field may be on compute OR data domain
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(in)  ::  local(:,:,:)
+      MPP_TYPE_, intent(out) :: global(domain%x%global%begin:,domain%y%global%begin:,:)
+      integer, intent(in), optional :: flags
+      integer :: i, j, k, m, n, nd, nwords, lpos, rpos, ioff, joff
+      logical :: xonly, yonly
+      MPP_TYPE_ :: clocal (domain%x%compute%size*    domain%y%compute%size*    size(local,3))
+      MPP_TYPE_ :: cremote(domain%x%compute%max_size*domain%y%compute%max_size*size(local,3))
+      integer :: words_per_long, stackuse
+      character(len=8) :: text
+#ifdef use_CRI_pointers
+      pointer( ptr_local,  clocal  )
+      pointer( ptr_remote, cremote )
+
+      ptr_local  = LOC(mpp_domains_stack)
+      ptr_remote = LOC(mpp_domains_stack(size(clocal)+1))
+#endif
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' )
+      xonly = .FALSE.
+      yonly = .FALSE.
+      if( PRESENT(flags) )then
+          xonly = flags.EQ.XUPDATE
+          yonly = flags.EQ.YUPDATE
+          if( .NOT.xonly .AND. .NOT.yonly )call mpp_error( WARNING, 'MPP_GLOBAL_FIELD: you must have flags=XUPDATE or YUPDATE.' )
+      end if
+
+#ifdef use_CRI_pointers
+      words_per_long = size(transfer(local(1,1,1),mpp_domains_stack))
+      stackuse = (size(clocal)+size(cremote))*words_per_long
+      if( stackuse.GT.mpp_domains_stack_size )then
+          write( text, '(i8)' )stackuse
+          call mpp_error( FATAL, &
+               'MPP_UPDATE_DOMAINS user stack overflow: call mpp_domains0_set_stack_size('//trim(text)//') from all PEs.' )
+      end if
+      ptr_local  = LOC(mpp_domains_stack)
+      ptr_remote = LOC( mpp_domains_stack((size(clocal)+1)*words_per_long) )
+      mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse )
+#endif
+      if( size(global,1).NE.domain%x%global%size .OR. size(global,2).NE.domain%y%global%size .OR. &
+          size(local,3).NE.size(global,3) ) &
+           call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: incoming arrays do not match domain.' )
+    if( size(local,1).EQ.domain%x%compute%size .AND. size(local,2).EQ.domain%y%compute%size )then
+!local is on compute domain
+        ioff = -domain%x%compute%begin + 1
+        joff = -domain%y%compute%begin + 1
+    else if( size(local,1).EQ.domain%x%data%size .AND. size(local,2).EQ.domain%y%data%size )then
+!local is on data domain
+        ioff = -domain%x%data%begin + 1
+        joff = -domain%y%data%begin + 1
+    else
+        call mpp_error( FATAL, 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or data domain.' )
+    end if
+
+! make contiguous array from compute domain
+      m = 0
+      do k = 1,size(local,3)
+         do j = domain%y%compute%begin,domain%y%compute%end
+            do i = domain%x%compute%begin,domain%x%compute%end
+               m = m + 1
+               clocal(m) = local(i+ioff,j+joff,k)
+               global(i,j,k) = clocal(m) !always fill local domain directly
+            end do
+         end do
+      end do
+
+!fill off-domains (note loops begin at an offset of 1)
+      if( xonly )then
+          nd = size(domain%x%list)
+          do n = 1,nd-1
+             lpos = mod(domain%x%pos+nd-n,nd)
+             rpos = mod(domain%x%pos   +n,nd)
+             nwords = domain%x%list(rpos)%compute%size * domain%x%list(rpos)%compute%size * size(local,3)
+             call mpp_transmit( clocal, size(clocal), domain%x%list(lpos)%pe, cremote, nwords, domain%x%list(rpos)%pe )
+             m = 0
+             do k = 1,size(global,3)
+                do j = domain%y%compute%begin,domain%y%compute%end
+                   do i = domain%x%list(rpos)%compute%begin,domain%x%list(rpos)%compute%end
+                      m = m + 1
+                      global(i,j,k) = cremote(m)
+                   end do
+                end do
+             end do
+          end do
+          call mpp_sync_self(domain%x%list(:)%pe)
+      else if( yonly )then
+          nd = size(domain%y%list)
+          do n = 1,nd-1
+             lpos = mod(domain%y%pos+nd-n,nd)
+             rpos = mod(domain%y%pos   +n,nd)
+             nwords = domain%y%list(rpos)%compute%size * domain%y%list(rpos)%compute%size * size(local,3)
+             call mpp_transmit( clocal, size(clocal), domain%y%list(lpos)%pe, cremote, nwords, domain%y%list(rpos)%pe )
+             m = 0
+             do k = 1,size(global,3)
+                do j = domain%y%list(rpos)%compute%begin,domain%y%list(rpos)%compute%end
+                   do i = domain%x%compute%begin,domain%x%compute%end
+                      m = m + 1
+                      global(i,j,k) = cremote(m)
+                   end do
+                end do
+             end do
+          end do
+          call mpp_sync_self(domain%y%list(:)%pe)
+      else
+          nd = size(domain%list)
+          do n = 1,nd-1
+             lpos = mod(domain%pos+nd-n,nd)
+             rpos = mod(domain%pos   +n,nd)
+             nwords = domain%list(rpos)%x%compute%size * domain%list(rpos)%y%compute%size * size(local,3)
+             call mpp_transmit( clocal, size(clocal), domain%list(lpos)%pe, cremote, nwords, domain%list(rpos)%pe )
+             m = 0
+             do k = 1,size(global,3)
+                do j = domain%list(rpos)%y%compute%begin,domain%list(rpos)%y%compute%end
+                   do i = domain%list(rpos)%x%compute%begin,domain%list(rpos)%x%compute%end
+                      m = m + 1
+                      global(i,j,k) = cremote(m)
+                   end do
+                end do
+             end do
+          end do
+!          call mpp_sync_self(domain%list(:)%pe)
+          call mpp_sync_self()
+      end if
+          
+      return
+    end subroutine MPP_GLOBAL_FIELD_3D_
+
+    subroutine MPP_GLOBAL_FIELD_4D_( domain, local, global, flags )
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(in)  ::  local(:,:,:,:)
+      MPP_TYPE_, intent(out) :: global(:,:,:,:)
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size(local,4))
+      MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4))
+#ifdef use_CRI_pointers
+      pointer( lptr, local3D  )
+      pointer( gptr, global3D )
+      lptr = LOC(local)
+      gptr = LOC(global)
+      call mpp_global_field( domain, local3D, global3D, flags )
+#else
+      local3D = RESHAPE( local, SHAPE(local3D) )
+      call mpp_global_field( domain, local3D, global3D, flags )
+      global = RESHAPE( global3D, SHAPE(global) )
+#endif
+    end subroutine MPP_GLOBAL_FIELD_4D_
+
+    subroutine MPP_GLOBAL_FIELD_5D_( domain, local, global, flags )
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(in)  ::  local(:,:,:,:,:)
+      MPP_TYPE_, intent(out) :: global(:,:,:,:,:)
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size( local,4)*size(local,5))
+      MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5))
+#ifdef use_CRI_pointers
+      pointer( lptr, local3D  )
+      pointer( gptr, global3D )
+      lptr = LOC(local)
+      gptr = LOC(global)
+      call mpp_global_field( domain, local3D, global3D, flags )
+#else
+      local3D = RESHAPE( local, SHAPE(local3D) )
+      call mpp_global_field( domain, local3D, global3D, flags )
+      global = RESHAPE( global3D, SHAPE(global) )
+#endif
+    end subroutine MPP_GLOBAL_FIELD_5D_
+
+    subroutine MPP_GLOBAL1D_FIELD_2D_( domain, local, global )
+      type(domain1D), intent(in) :: domain
+      MPP_TYPE_, intent(in)  ::  local(domain%data%begin:  ,:)
+      MPP_TYPE_, intent(out) :: global(domain%global%begin:,:)
+      integer :: i, n, nwords, lpos, rpos
+      MPP_TYPE_, allocatable, dimension(:) :: clocal, cremote
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' )
+
+      if( size(local,1).NE.domain%data%size   .OR. size(global,1).NE.domain%global%size .OR. &
+          size(local,2).NE.size(global,2) ) &
+           call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: incoming arrays do not match domain.' )
+
+      allocate( clocal (domain%compute%size    *size(local,2)) )
+      allocate( cremote(domain%compute%max_size*size(local,2)) )
+      clocal = TRANSFER( local(domain%compute%begin:domain%compute%end,:), clocal )
+!always fill local directly
+      global(domain%compute%begin:domain%compute%end,:) = local(domain%compute%begin:domain%compute%end,:)
+!fill off-domains (note loops begin at an offset of 1)
+      n = size(domain%list)
+      do i = 1,n-1
+         lpos = mod(domain%pos+n-i,n)
+         rpos = mod(domain%pos  +i,n)
+         nwords = domain%list(rpos)%compute%size * size(local,2)
+         call mpp_transmit( clocal, size(clocal), domain%list(lpos)%pe, cremote, nwords, domain%list(rpos)%pe )
+         global(domain%list(rpos)%compute%begin:domain%list(rpos)%compute%end,:) = &
+              RESHAPE( cremote(1:nwords), (/domain%list(rpos)%compute%size,size(local,2)/) )
+      end do
+      call mpp_sync_self(domain%list(:)%pe)
+!PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
+      deallocate( clocal, cremote )
+          
+      return
+    end subroutine MPP_GLOBAL1D_FIELD_2D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_reduce.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_reduce.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_reduce.h	(revision 1677)
@@ -0,0 +1,150 @@
+  function MPP_GLOBAL_REDUCE_2D_( domain, field, locus )
+    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_2D_
+    type(domain2D), intent(in) :: domain
+    MPP_TYPE_, intent(in) :: field(:,:)
+    integer, intent(out), optional :: locus(2)
+    MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
+    integer :: locus3D(3)
+#ifdef use_CRI_pointers
+    pointer( ptr, field3D )
+    ptr = LOC(field)
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus = locus3D(1:2)
+    else
+        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#else
+    field3D = RESHAPE( field, SHAPE(field3D) )
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus = locus3D(1:2)
+    else
+        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#endif
+    return
+  end function MPP_GLOBAL_REDUCE_2D_
+
+  function MPP_GLOBAL_REDUCE_3D_( domain, field, locus )
+    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_3D_
+    type(domain2D), intent(in) :: domain
+    MPP_TYPE_, intent(in) :: field(0:,0:,:)
+    integer, intent(out), optional :: locus(3)
+    MPP_TYPE_ :: local
+    integer :: here, ioff, joff
+
+    if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE: You must first call mpp_domains_init.' )
+    if( size(field,1).EQ.domain%x%compute%size .AND. size(field,2).EQ.domain%y%compute%size )then
+!field is on compute domain
+        ioff = domain%x%compute%begin
+        joff = domain%y%compute%begin
+    else if( size(field,1).EQ.domain%x%data%size .AND. size(field,2).EQ.domain%y%data%size )then
+!field is on data domain
+        ioff = domain%x%data%begin
+        joff = domain%y%data%begin
+    else
+        call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE_: incoming field array must match either compute domain or data domain.' )
+    end if
+
+!get your local max/min
+    local = REDUCE_VAL_(field)
+!find the global
+    MPP_GLOBAL_REDUCE_3D_ = local
+    call MPP_REDUCE_( MPP_GLOBAL_REDUCE_3D_, domain%list(:)%pe )
+!find locus of the global max/min
+    if( PRESENT(locus) )then
+!which PE is it on? min of all the PEs that have it
+        here = mpp_npes()+1
+        if( MPP_GLOBAL_REDUCE_3D_.EQ.local )here = pe
+        call mpp_min( here, domain%list(:)%pe )
+!find the locus here
+        if( pe.EQ.here )locus = REDUCE_LOC_(field)
+        locus(1) = locus(1) + ioff
+        locus(2) = locus(2) + joff
+        call mpp_broadcast( locus, 3, here, domain%list(:)%pe )
+    end if
+    return
+  end function MPP_GLOBAL_REDUCE_3D_
+
+  function MPP_GLOBAL_REDUCE_4D_( domain, field, locus )
+    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_4D_
+    type(domain2D), intent(in) :: domain
+    MPP_TYPE_, intent(in) :: field(:,:,:,:)
+    integer, intent(out), optional :: locus(4)
+    MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
+    integer :: locus3D(3)
+#ifdef use_CRI_pointers
+    pointer( ptr, field3D )
+    ptr = LOC(field)
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus(1:2) = locus3D(1:2)
+        locus(3) = modulo(locus3D(3),size(field,3))
+        locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
+        if( locus(3).EQ.0 )then
+            locus(3) = size(field,3)
+            locus(4) = locus(4) - 1
+        end if
+    else
+        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#else
+    field3D = RESHAPE( field, SHAPE(field3D) )
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus(1:2) = locus3D(1:2)
+        locus(3) = modulo(locus3D(3),size(field,3))
+        locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
+        if( locus(3).EQ.0 )then
+            locus(3) = size(field,3)
+            locus(4) = locus(4) - 1
+        end if
+    else
+        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#endif
+    return
+  end function MPP_GLOBAL_REDUCE_4D_
+
+  function MPP_GLOBAL_REDUCE_5D_( domain, field, locus )
+    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_5D_
+    type(domain2D), intent(in) :: domain
+    MPP_TYPE_, intent(in) :: field(:,:,:,:,:)
+    integer, intent(out), optional :: locus(5)
+    MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
+    integer :: locus3D(3)
+#ifdef use_CRI_pointers
+    pointer( ptr, field3D )
+    ptr = LOC(field)
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus(1:2) = locus3D(1:2)
+        locus(3) = modulo(locus3D(3),size(field,3))
+        locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
+        locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
+        if( locus(3).EQ.0 )then
+            locus(3) = size(field,3)
+            locus(4) = locus(4) - 1
+        end if
+    else
+        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#else
+    field3D = RESHAPE( field, SHAPE(field3D) )
+    if( PRESENT(locus) )then
+        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
+        locus(1:2) = locus3D(1:2)
+        locus(3) = modulo(locus3D(3),size(field,3))
+        locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
+        locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
+        if( locus(3).EQ.0 )then
+            locus(3) = size(field,3)
+            locus(4) = locus(4) - 1
+        end if
+    else
+        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
+    end if
+#endif
+    return
+  end function MPP_GLOBAL_REDUCE_5D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_sum.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_sum.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_sum.h	(revision 1677)
@@ -0,0 +1,43 @@
+  function MPP_GLOBAL_SUM_( domain, field, flags )
+    MPP_TYPE_ :: MPP_GLOBAL_SUM_
+    type(domain2D), intent(in) :: domain
+    MPP_TYPE_, intent(in) :: field(:,: MPP_EXTRA_INDICES_ )
+    integer, intent(in), optional :: flags
+    MPP_TYPE_, allocatable, dimension(:,:) :: field2D, global2D
+    integer :: i,j, ioff,joff
+
+    if( size(field,1).EQ.domain%x%compute%size .AND. size(field,2).EQ.domain%y%compute%size )then
+!field is on compute domain
+        ioff = -domain%x%compute%begin + 1
+        joff = -domain%y%compute%begin + 1
+    else if( size(field,1).EQ.domain%x%data%size .AND. size(field,2).EQ.domain%y%data%size )then
+!field is on data domain
+        ioff = -domain%x%data%begin + 1
+        joff = -domain%y%data%begin + 1
+    else
+        call mpp_error( FATAL, 'MPP_GLOBAL_SUM_: incoming field array must match either compute domain or data domain.' )
+    end if
+    if( PRESENT(flags) )then
+        if( flags.NE.BITWISE_EXACT_SUM )call mpp_error( FATAL, 'MPP_GLOBAL_SUM_: only valid flag is BITWISE_EXACT_SUM.' )
+!this is bitwise exact across different PE counts.
+        allocate( field2D(domain%x%compute%begin:domain%x%compute%end,domain%y%compute%begin:domain%y%compute%end) )
+        allocate( global2D(domain%x%global%size,domain%y%global%size) )
+        do j = domain%y%compute%begin, domain%y%compute%end
+           do i = domain%x%compute%begin, domain%x%compute%end
+              field2D(i,j) = sum( field(i+ioff:i+ioff,j+joff:j+joff MPP_EXTRA_INDICES_) )
+           end do
+        end do
+
+        call mpp_global_field( domain, field2D, global2D )
+        MPP_GLOBAL_SUM_ = sum(global2D)
+        deallocate( field2D)
+        deallocate(global2D)
+    else
+!this is not bitwise-exact across different PE counts
+        MPP_GLOBAL_SUM_ = sum( field(domain%x%compute%begin+ioff:domain%x%compute%end+ioff, &
+                                     domain%y%compute%begin+joff:domain%y%compute%end+joff MPP_EXTRA_INDICES_) )
+        call mpp_sum( MPP_GLOBAL_SUM_, domain%list(:)%pe )
+    end if
+
+    return
+  end function MPP_GLOBAL_SUM_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_read_2Ddecomp.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_read_2Ddecomp.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_read_2Ddecomp.h	(revision 1677)
@@ -0,0 +1,111 @@
+    subroutine MPP_READ_2DDECOMP_1D_( unit, field, domain, data, tindex )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(inout) :: data(:)
+      integer, intent(in), optional :: tindex
+      integer::il_xbegin,il_xend,il_ybegin,il_yend
+      MPP_TYPE_,allocatable :: data3D(:,:,:)
+        
+      call mpp_get_compute_domain(domain &
+                                ,xbegin=il_xbegin,xend=il_xend &
+                                ,ybegin=il_ybegin,yend=il_yend)
+
+      allocate(data3D(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1,1:1))
+      data3D = RESHAPE( data, SHAPE(data3D) )
+      call mpp_read( unit, field, domain, data3D, tindex )
+      data   = RESHAPE( data3D, SHAPE(data) )
+      deallocate(data3D)
+          
+      return
+    end subroutine MPP_READ_2DDECOMP_1D_
+    subroutine MPP_READ_2DDECOMP_2D_( unit, field, domain, data, tindex )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(inout) :: data(:,:)
+      integer, intent(in), optional :: tindex
+      MPP_TYPE_ :: data3D(size(data,1),size(data,2),1)
+#ifdef use_CRI_pointers
+      pointer( ptr, data3D )
+      ptr = LOC(data)
+      call mpp_read( unit, field, domain, data3D, tindex )
+#else
+      data3D = RESHAPE( data, SHAPE(data3D) )
+      call mpp_read( unit, field, domain, data3D, tindex )
+      data   = RESHAPE( data3D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_READ_2DDECOMP_2D_
+
+    subroutine MPP_READ_2DDECOMP_3D_( unit, field, domain, data, tindex )
+!mpp_read reads <data> which has the domain decomposition <domain>
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(inout) :: data(:,:,:)
+      integer, intent(in), optional :: tindex
+      MPP_TYPE_, allocatable :: cdata(:,:,:)
+      MPP_TYPE_, allocatable :: gdata(:)
+      integer :: len, lenx,leny,lenz,i,j,k,n
+!NEW: data may be on compute OR data domain
+      logical :: data_has_halos, halos_are_global, x_is_global, y_is_global
+      integer :: is, ie, js, je, isd, ied, jsd, jed, isg, ieg, jsg, jeg, ioff, joff
+
+      if (.NOT. present(tindex) .AND. mpp_file(unit)%time_level .ne. -1) &
+      call mpp_error(FATAL, 'MPP_READ: need to specify a time level for data with time axis')
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_READ: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_READ: invalid unit number.' )
+
+      call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
+      call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, x_is_global=x_is_global, y_is_global=y_is_global )
+      call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg )
+      if( size(data,1).EQ.ie-is+1 .AND. size(data,2).EQ.je-js+1 )then
+          data_has_halos = .FALSE.
+      else if( size(data,1).EQ.ied-isd+1 .AND. size(data,2).EQ.jed-jsd+1 )then
+          data_has_halos = .TRUE.
+      else
+          call mpp_error( FATAL, 'MPP_READ: data must be either on compute domain or data domain.' )
+      end if
+      halos_are_global = x_is_global .AND. y_is_global
+      if( npes.GT.1 .AND. mpp_file(unit)%threading.EQ.MPP_SINGLE )then
+          if( halos_are_global )then !you can read directly into data array
+              if( pe.EQ.0 )call read_record( unit, field, size(data), data, tindex )
+          else
+              lenz=size(data,3)
+              len=lenx*leny*lenz
+              allocate(gdata(len))          
+! read field on pe 0 and pass to all pes
+              if( pe.EQ.0 ) call read_record( unit, field, len, gdata, tindex )
+! broadcasting global array, this can be expensive!          
+              call mpp_transmit( gdata, len, ALL_PES, gdata, len, 0 )
+              ioff = is; joff = js
+              if( data_has_halos )then
+                  ioff = isd; joff = jsd
+              end if
+              do k=1,size(data,3)
+                 do j=js,je
+                    do i=is,ie
+                       n=(i-isg+1) + (j-jsg)*lenx + (k-1)*lenx*leny
+                       data(i-ioff+1,j-joff+1,k)=gdata(n)
+                    enddo
+                 enddo
+              enddo
+              deallocate(gdata)
+          end if
+      else if( data_has_halos )then
+! for uniprocessor or multithreaded read
+! read compute domain as contiguous data
+
+          allocate( cdata(is:ie,js:je,size(data,3)) )
+          call read_record(unit,field,size(cdata),cdata,tindex,domain)
+
+          data(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1,:) = cdata(:,:,:)
+          deallocate(cdata)
+      else
+          call read_record(unit,field,size(data),data,tindex,domain)
+      end if
+
+      return
+    end subroutine MPP_READ_2DDECOMP_3D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_reduce.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_reduce.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_reduce.h	(revision 1677)
@@ -0,0 +1,43 @@
+    subroutine MPP_REDUCE_( a, pelist )
+!find the max of scalar a the PEs in pelist (all PEs if this argument is omitted)
+!result is also automatically broadcast to all PEs
+      MPP_TYPE_, intent(inout) :: a
+      integer, intent(in), optional :: pelist(0:)
+      integer :: n
+#ifdef use_libSMA
+!work holds pWrk array + 1 word for symmetric copy of a
+      MPP_TYPE_ :: work(SHMEM_REDUCE_MIN_WRKDATA_SIZE+1)
+      pointer( ptr, work )
+      integer :: words
+      character(len=8) :: text
+#endif /* use_libSMA */
+#ifdef use_libMPI
+      MPP_TYPE_ :: work
+#endif
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE: You must first call mpp_init.' )
+      n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
+
+      if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#ifdef use_libSMA
+!allocate space from the stack for pwrk and b
+      ptr = LOC(mpp_stack)
+      words = size(work)*size(transfer(work(1),word))
+      if( words.GT.mpp_stack_size )then
+          write( text, '(i8)' )words
+          call mpp_error( FATAL, 'MPP_REDUCE user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' )
+      end if
+      mpp_stack_hwm = max( words, mpp_stack_hwm )
+      
+      work(1) = a
+      call SHMEM_REDUCE_( work, work, 1, peset(n)%start, peset(n)%log2stride, peset(n)%count, work(2), sync )
+      call mpp_sync(pelist)
+      a = work(1)
+#endif /* use_libSMA */
+#ifdef use_libMPI
+      if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_: using MPI_ALLREDUCE...' )
+      call MPI_ALLREDUCE( a, work, 1, MPI_TYPE_, MPI_REDUCE_, peset(n)%id, error )
+      a = work
+#endif
+      if( current_clock.NE.0 )call increment_current_clock( EVENT_ALLREDUCE, MPP_TYPE_BYTELEN_ )
+      return
+    end subroutine MPP_REDUCE_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_sum.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_sum.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_sum.h	(revision 1677)
@@ -0,0 +1,129 @@
+    subroutine MPP_SUM_( a, length, pelist )
+!sums array a over the PEs in pelist (all PEs if this argument is omitted)
+!result is also automatically broadcast: all PEs have the sum in a at the end
+!we are using f77-style call: array passed by address and not descriptor; further, the f90 conformance check is avoided.
+      integer, intent(in) :: length
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_, intent(inout) :: a(*)
+      integer :: n
+#ifdef use_libSMA
+!first <length> words are array, rest are pWrk
+      MPP_TYPE_ :: work(length+length/2+1+SHMEM_REDUCE_MIN_WRKDATA_SIZE)
+      pointer( ptr, work )
+      integer :: words
+      character(len=8) :: text
+#else
+      MPP_TYPE_ :: work(length)
+#endif
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' )
+      n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
+
+      if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#ifdef use_libSMA
+!allocate space from the stack for pwrk and b
+      ptr = LOC(mpp_stack)
+      words = size(work)*size(transfer(work(1),word))
+      if( words.GT.mpp_stack_size )then
+          write( text, '(i8)' )words
+          call mpp_error( FATAL, 'MPP_SUM user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' )
+      end if
+      mpp_stack_hwm = max( words, mpp_stack_hwm )
+      work(1:length) = a(1:length)
+      call mpp_sync(pelist)
+      call SHMEM_SUM_( work, work, length, peset(n)%start, peset(n)%log2stride, peset(n)%count, work(length+1), sync )
+#endif /* use_libSMA */
+#ifdef use_libMPI
+      if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' )
+      if( debug )write( stderr(),* )'pe, n, peset(n)%id=', pe, n, peset(n)%id
+      call MPI_ALLREDUCE( a, work, length, MPI_TYPE_, MPI_SUM, peset(n)%id, error )
+#endif
+      a(1:length) = work(1:length)
+      if( current_clock.NE.0 )call increment_current_clock( EVENT_ALLREDUCE, length*MPP_TYPE_BYTELEN_ )
+      return
+    end subroutine MPP_SUM_
+
+    subroutine MPP_SUM_SCALAR_( a, pelist )
+!sums array a when only first element is passed: this routine just converts to a call to MPP_SUM_
+      MPP_TYPE_, intent(inout) :: a
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: b(1)
+
+      b(1) = a
+      if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' )
+      call MPP_SUM_( b, 1, pelist )
+      a = b(1)
+      return
+    end subroutine MPP_SUM_SCALAR_
+
+    subroutine MPP_SUM_2D_( a, length, pelist )
+      MPP_TYPE_, intent(inout) :: a(:,:)
+      integer, intent(in) :: length
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: a1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, a1D )
+      ptr = LOC(a)
+#else
+!faster than RESHAPE? length is probably redundant
+      a1D = TRANSFER( a, a1D, length ) 
+!      a1D = RESHAPE( a, SHAPE(a1D) )
+      call mpp_sum( a1D, length, pelist )
+      a = RESHAPE( a1D, SHAPE(a) )
+#endif
+      return
+    end subroutine MPP_SUM_2D_
+
+    subroutine MPP_SUM_3D_( a, length, pelist )
+      MPP_TYPE_, intent(inout) :: a(:,:,:)
+      integer, intent(in) :: length
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: a1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, a1D )
+      ptr = LOC(a)
+#else
+!faster than RESHAPE? length is probably redundant
+      a1D = TRANSFER( a, a1D, length )
+!      a1D = RESHAPE( a, SHAPE(a1D) )
+      call mpp_sum( a1D, length, pelist )
+      a = RESHAPE( a1D, SHAPE(a) )
+#endif
+      return
+    end subroutine MPP_SUM_3D_
+
+    subroutine MPP_SUM_4D_( a, length, pelist )
+      MPP_TYPE_, intent(inout) :: a(:,:,:,:)
+      integer, intent(in) :: length
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: a1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, a1D )
+      ptr = LOC(a)
+#else
+!faster than RESHAPE? length is probably redundant
+      a1D = TRANSFER( a, a1D, length )
+!      a1D = RESHAPE( a, SHAPE(a1D) )
+      call mpp_sum( a1D, length, pelist )
+      a = RESHAPE( a1D, SHAPE(a) )
+#endif
+      return
+    end subroutine MPP_SUM_4D_
+
+    subroutine MPP_SUM_5D_( a, length, pelist )
+      MPP_TYPE_, intent(inout) :: a(:,:,:,:,:)
+      integer, intent(in) :: length
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: a1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, a1D )
+      ptr = LOC(a)
+#else
+!faster than RESHAPE? length is probably redundant
+      a1D = TRANSFER( a, a1D, length )
+!      a1D = RESHAPE( a, SHAPE(a1D) )
+      call mpp_sum( a1D, length, pelist )
+      a = RESHAPE( a1D, SHAPE(a) )
+#endif
+      return
+    end subroutine MPP_SUM_5D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_transmit.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_transmit.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_transmit.h	(revision 1677)
@@ -0,0 +1,618 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                                  MPP_TRANSMIT                               !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine MPP_TRANSMIT_( put_data, put_len, to_pe, get_data, get_len, from_pe )
+!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM
+
+!put_data and get_data are contiguous MPP_TYPE_ arrays
+
+!at each call, your put_data array is put to   to_pe's get_data
+!              your get_data array is got from from_pe's put_data
+!i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get
+
+!special PE designations:
+!      NULL_PE: to disable a put or a get (e.g at boundaries)
+!      ANY_PE:  if remote PE for the put or get is to be unspecific
+!      ALL_PES: broadcast and collect operations (collect not yet implemented)
+
+!ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor)
+!further, this permits <length> contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check)
+
+!caller is responsible for completion checks (mpp_sync_self) before and after
+
+      integer, intent(in) :: put_len, to_pe, get_len, from_pe
+      MPP_TYPE_, intent(in)  :: put_data(*)
+      MPP_TYPE_, intent(out) :: get_data(*)
+      integer :: i
+#ifdef use_libSMA
+      integer :: np
+      integer(LONG_KIND) :: data_loc
+!pointer to remote data
+      MPP_TYPE_ :: remote_data(get_len)
+      pointer( ptr_remote_data, remote_data )
+      MPP_TYPE_ :: broadcast_data(get_len)
+      pointer( ptr, broadcast_data )
+      integer :: words
+      character(len=8) :: text
+#endif
+      MPP_TYPE_, allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI)
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' )
+      if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return
+      
+      if( debug )then
+          call SYSTEM_CLOCK(tick)
+          write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
+               'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len
+      end if
+
+!do put first and then get
+      if( to_pe.GE.0 .AND. to_pe.LT.npes )then
+#ifdef use_libSMA
+!send data pointer to to_pe
+#ifdef _CRAYT90
+          call SHMEM_UDCFLUSH !invalidate data cache
+#endif
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call SHMEM_INT8_WAIT( status(to_pe), MPP_WAIT )
+          status(to_pe) = MPP_WAIT !prohibit puts to to_pe until it has retrieved this message
+          if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
+          data_loc = LOC(put_data)
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call SHMEM_INTEGER_PUT( mpp_from_pe, pe, 1, to_pe )
+          call SHMEM_PUT8( remote_data_loc(pe), data_loc, 1, to_pe )
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_SEND, put_len*MPP_TYPE_BYTELEN_ )
+#elif use_libMPI
+!use non-blocking sends
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue 
+!              if( debug )write( stderr(),* )'PE waiting ', pe, to_pe
+              call MPI_WAIT( request(to_pe), stat, error )
+          end if
+          call MPI_ISEND( put_data, put_len, MPI_TYPE_, to_pe, tag, peset(0)%id, request(to_pe), error )
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_SEND, put_len*MPP_TYPE_BYTELEN_ )
+#else                         /*  !neither SHMEM nor MPI */
+          if( allocated(local_data) ) &
+               call mpp_error( FATAL, 'MPP_TRANSMIT: local_data should have been deallocated by prior receive.' )
+          allocate( local_data(put_len) )
+          do i = 1,put_len
+             local_data(i) = put_data(i)
+          end do
+#endif
+
+      else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe
+          if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' )
+          if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' )
+          if( pe.EQ.from_pe )then
+#ifdef use_CRI_pointers
+              if( LOC(get_data).NE.LOC(put_data) )then
+!dir$ IVDEP
+#endif
+                  do i = 1,get_len
+                     get_data(i) = put_data(i)
+                  end do
+#ifdef use_CRI_pointers
+              end if
+#endif
+          end if
+          call mpp_broadcast( get_data, get_len, from_pe )
+          return
+
+      else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets
+#ifdef use_libSMA
+          if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe along with to_pe=ANY_PE.' )
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call SHMEM_GET_( get_data, put_data, get_len, from_pe )
+          call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe that you have retrieved this message
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
+          return
+#endif
+#ifdef use_libMPI
+!...but you cannot have a pure get with MPI
+          call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' )
+#endif
+
+      else if( to_pe.NE.NULL_PE )then	!no other valid cases except NULL_PE
+          call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' )
+      end if
+
+!do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete
+      if( from_pe.GE.0 .AND. from_pe.LT.npes )then
+#ifdef use_libSMA
+#ifdef _CRAYT90
+          call SHMEM_UDCFLUSH !invalidate data cache
+#endif
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          if( debug )write( stderr(),* )'pe, from_pe, remote_data_loc(from_pe)=', pe, from_pe, remote_data_loc(from_pe)
+          call SHMEM_INT8_WAIT( remote_data_loc(from_pe), MPP_WAIT )
+          if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
+          ptr_remote_data = remote_data_loc(from_pe)
+          remote_data_loc(from_pe) = MPP_WAIT !reset
+!          call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe we have retrieved the location
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#if defined(CRAYPVP) || defined(sgi_mipspro)
+!since we have the pointer to remote data, just retrieve it with a simple copy
+          if( LOC(get_data).NE.LOC(remote_data) )then
+!dir$ IVDEP
+              do i = 1,get_len
+                 get_data(i) = remote_data(i)
+              end do
+          else
+              call mpp_error(FATAL)
+          end if
+#else
+          call SHMEM_GET_( get_data, remote_data, get_len, from_pe )
+#endif
+          call SHMEM_PUT8( status(pe), MPP_READY, 1, from_pe ) !tell from_pe we have retrieved the location
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
+#elif  use_libMPI
+!receive from from_pe
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call MPI_RECV( get_data, get_len, MPI_TYPE_, from_pe, MPI_ANY_TAG, peset(0)%id, stat, error )
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
+#else                   /*        !neither SHMEM nor MPI */
+          if( .NOT.allocated(local_data) ) &
+               call mpp_error( FATAL, 'MPP_TRANSMIT: local_data should have been allocated by prior send.' )
+          do i = 1,get_len
+             get_data(i) = local_data(i)
+          end do
+          deallocate(local_data)
+!#else !neither use_libSMA nor use_libMPI
+!          if( pe.EQ.from_pe )then
+!#ifdef use_CRI_pointers
+!!dir$ IVDEP
+!              if( LOC(get_data).NE.LOC(put_data) ) &
+!#endif
+!                   get_data(1:put_len) = put_data(1:put_len)
+!          end if
+#endif
+
+      else if( from_pe.EQ.ANY_PE )then
+#ifdef use_libSMA
+#ifdef _CRAYT90
+          call SHMEM_UDCFLUSH !invalidate data cache
+#endif
+!since we don't know which PE is sending us data, we wait for remote PE to send us its ID
+!this is only required for !CRAYPVP  && !sgi_mipspro, but is done there too, so that we can send put_is_done back.
+          call shmem_integer_wait( mpp_from_pe, ANY_PE )
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call SHMEM_INT8_WAIT( remote_data_loc(mpp_from_pe), MPP_WAIT )
+          if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
+          ptr_remote_data = remote_data_loc(mpp_from_pe)
+          remote_data_loc(mpp_from_pe) = MPP_WAIT !reset
+          call SHMEM_PUT8( status(pe), MPP_READY, 1, mpp_from_pe ) !tell mpp_from_pe we have retrieved the location
+#if defined(CRAYPVP) || defined(sgi_mipspro)
+!since we have the pointer to remote data, just retrieve it with a simple copy
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          if( LOC(get_data).NE.LOC(remote_data) )then
+!dir$ IVDEP
+              do i = 1,get_len
+                 get_data(i) = remote_data(i)
+              end do
+          end if
+#else
+          call SHMEM_GET_( get_data, remote_data, get_len, mpp_from_pe )
+#endif
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
+          mpp_from_pe = ANY_PE   !reset
+#endif / *use_libSMA */
+#ifdef use_libMPI
+!receive from MPI_ANY_SOURCE
+          if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+          call MPI_RECV( get_data, get_len, MPI_TYPE_, MPI_ANY_SOURCE, MPI_ANY_TAG, peset(0)%id, stat, error )
+          if( current_clock.NE.0 )call increment_current_clock( EVENT_RECV, get_len*MPP_TYPE_BYTELEN_ )
+#endif
+
+      else if( from_pe.EQ.ALL_PES )then
+          call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' )
+
+      else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE
+          call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' )
+      end if
+
+      if( debug )then
+          call SYSTEM_CLOCK(tick)
+          write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
+               'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len
+      end if
+      return
+    end subroutine MPP_TRANSMIT_
+
+    subroutine MPP_TRANSMIT_SCALAR_( put_data, to_pe, get_data, from_pe )
+      integer, intent(in) :: to_pe, from_pe
+      MPP_TYPE_, intent(in)  :: put_data
+      MPP_TYPE_, intent(out) :: get_data
+      MPP_TYPE_ :: put_data1D(1), get_data1D(1)
+#ifdef use_CRI_pointers
+      pointer( ptrp, put_data1D )
+      pointer( ptrg, get_data1D )
+
+      ptrp = LOC(put_data)
+      ptrg = LOC(get_data)
+      call MPP_TRANSMIT_ ( put_data1D, 1, to_pe, get_data1D, 1, from_pe )
+#else
+      put_data1D(1) = put_data
+      call MPP_TRANSMIT_ ( put_data1D, 1, to_pe, get_data1D, 1, from_pe )
+      get_data = get_data1D(1)
+#endif
+      return
+    end subroutine MPP_TRANSMIT_SCALAR_
+
+    subroutine MPP_TRANSMIT_2D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
+      integer, intent(in) :: put_len, to_pe, get_len, from_pe
+      MPP_TYPE_, intent(in)  :: put_data(:,:)
+      MPP_TYPE_, intent(out) :: get_data(:,:)
+      MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
+#ifdef use_CRI_pointers
+      pointer( ptrp, put_data1D )
+      pointer( ptrg, get_data1D )
+      ptrp = LOC(put_data)
+      ptrg = LOC(get_data)
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+#else
+!faster than RESHAPE? length is probably redundant
+      if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
+!      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+      if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
+#endif
+      return
+    end subroutine MPP_TRANSMIT_2D_
+
+    subroutine MPP_TRANSMIT_3D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
+      integer, intent(in) :: put_len, to_pe, get_len, from_pe
+      MPP_TYPE_, intent(in)  :: put_data(:,:,:)
+      MPP_TYPE_, intent(out) :: get_data(:,:,:)
+      MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
+#ifdef use_CRI_pointers
+      pointer( ptrp, put_data1D )
+      pointer( ptrg, get_data1D )
+      ptrp = LOC(put_data)
+      ptrg = LOC(get_data)
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+#else
+!faster than RESHAPE? length is probably redundant
+      if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
+!      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+      if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
+#endif
+      return
+    end subroutine MPP_TRANSMIT_3D_
+
+    subroutine MPP_TRANSMIT_4D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
+      integer, intent(in) :: put_len, to_pe, get_len, from_pe
+      MPP_TYPE_, intent(in)  :: put_data(:,:,:,:)
+      MPP_TYPE_, intent(out) :: get_data(:,:,:,:)
+      MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
+#ifdef use_CRI_pointers
+      pointer( ptrp, put_data1D )
+      pointer( ptrg, get_data1D )
+      ptrp = LOC(put_data)
+      ptrg = LOC(get_data)
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+#else
+!faster than RESHAPE? length is probably redundant
+      if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
+!      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+      if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
+#endif
+      return
+    end subroutine MPP_TRANSMIT_4D_
+
+    subroutine MPP_TRANSMIT_5D_( put_data, put_len, to_pe, get_data, get_len, from_pe )
+      integer, intent(in) :: put_len, to_pe, get_len, from_pe
+      MPP_TYPE_, intent(in)  :: put_data(:,:,:,:,:)
+      MPP_TYPE_, intent(out) :: get_data(:,:,:,:,:)
+      MPP_TYPE_ :: put_data1D(put_len), get_data1D(get_len)
+#ifdef use_CRI_pointers
+      pointer( ptrp, put_data1D )
+      pointer( ptrg, get_data1D )
+      ptrp = LOC(put_data)
+      ptrg = LOC(get_data)
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+#else
+!faster than RESHAPE? length is probably redundant
+      if( to_pe.NE.NULL_PE )put_data1D = TRANSFER( put_data, put_data1D, get_len )
+!      if( to_pe.NE.NULL_PE )put_data1D = RESHAPE( put_data, SHAPE(put_data1D) )
+      call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe )
+      if( from_pe.NE.NULL_PE )get_data = RESHAPE( get_data1D, SHAPE(get_data) )
+#endif
+      return
+    end subroutine MPP_TRANSMIT_5D_
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                              MPP_SEND and RECV                              !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine MPP_RECV_( get_data, get_len, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: get_len, from_pe
+      MPP_TYPE_, intent(out) :: get_data(*)
+      MPP_TYPE_ :: dummy(1)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
+    end subroutine MPP_RECV_
+
+    subroutine MPP_SEND_( put_data, put_len, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: put_len, to_pe
+      MPP_TYPE_, intent(in) :: put_data(*)
+      MPP_TYPE_ :: dummy(1)
+      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
+    end subroutine MPP_SEND_
+
+    subroutine MPP_RECV_SCALAR_( get_data, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: from_pe
+      MPP_TYPE_, intent(out) :: get_data
+      MPP_TYPE_ :: get_data1D(1)
+      MPP_TYPE_ :: dummy(1)
+#ifdef use_CRI_pointers
+      pointer( ptr, get_data1D )
+      ptr = LOC(get_data)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data1D, 1, from_pe )
+#else
+      call mpp_transmit( dummy, 1, NULL_PE, get_data1D, 1, from_pe )
+      get_data = get_data1D(1)
+#endif
+    end subroutine MPP_RECV_SCALAR_
+
+    subroutine MPP_SEND_SCALAR_( put_data, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: to_pe
+      MPP_TYPE_, intent(in) :: put_data
+      MPP_TYPE_ :: put_data1D(1)
+      MPP_TYPE_ :: dummy(1)
+#ifdef use_CRI_pointers
+      pointer( ptr, put_data1D )
+      ptr = LOC(put_data)
+      call mpp_transmit( put_data1D, 1, to_pe, dummy, 1, NULL_PE )
+#else
+      put_data1D(1) = put_data
+      call mpp_transmit( put_data1D, 1, to_pe, dummy, 1, NULL_PE )
+#endif
+    end subroutine MPP_SEND_SCALAR_
+
+    subroutine MPP_RECV_2D_( get_data, get_len, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: get_len, from_pe
+      MPP_TYPE_, intent(out) :: get_data(:,:)
+      MPP_TYPE_ :: dummy(1,1)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
+    end subroutine MPP_RECV_2D_
+
+    subroutine MPP_SEND_2D_( put_data, put_len, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: put_len, to_pe
+      MPP_TYPE_, intent(in) :: put_data(:,:)
+      MPP_TYPE_ :: dummy(1,1)
+      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
+    end subroutine MPP_SEND_2D_
+
+    subroutine MPP_RECV_3D_( get_data, get_len, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: get_len, from_pe
+      MPP_TYPE_, intent(out) :: get_data(:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
+    end subroutine MPP_RECV_3D_
+
+    subroutine MPP_SEND_3D_( put_data, put_len, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: put_len, to_pe
+      MPP_TYPE_, intent(in) :: put_data(:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1)
+      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
+    end subroutine MPP_SEND_3D_
+
+    subroutine MPP_RECV_4D_( get_data, get_len, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: get_len, from_pe
+      MPP_TYPE_, intent(out) :: get_data(:,:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1,1)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
+    end subroutine MPP_RECV_4D_
+
+    subroutine MPP_SEND_4D_( put_data, put_len, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: put_len, to_pe
+      MPP_TYPE_, intent(in) :: put_data(:,:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1,1)
+      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
+    end subroutine MPP_SEND_4D_
+
+    subroutine MPP_RECV_5D_( get_data, get_len, from_pe )
+!a mpp_transmit with null arguments on the put side
+      integer, intent(in) :: get_len, from_pe
+      MPP_TYPE_, intent(out) :: get_data(:,:,:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1,1,1)
+      call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe )
+    end subroutine MPP_RECV_5D_
+
+    subroutine MPP_SEND_5D_( put_data, put_len, to_pe )
+!a mpp_transmit with null arguments on the get side
+      integer, intent(in) :: put_len, to_pe
+      MPP_TYPE_, intent(in) :: put_data(:,:,:,:,:)
+      MPP_TYPE_ :: dummy(1,1,1,1,1)
+      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE )
+    end subroutine MPP_SEND_5D_
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                                MPP_BROADCAST                                !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine MPP_BROADCAST_( data, length, from_pe, pelist )
+!this call was originally bundled in with mpp_transmit, but that doesn't allow
+!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
+!backward compatible.
+      MPP_TYPE_, intent(inout) :: data(*)
+      integer, intent(in) :: length, from_pe
+      integer, intent(in), optional :: pelist(:)
+      integer :: n
+#ifdef use_libSMA
+      integer :: np, i
+      integer(LONG_KIND) :: data_loc
+!pointer to remote data
+      MPP_TYPE_ :: bdata(length)
+      pointer( ptr, bdata )
+      integer :: words
+      character(len=8) :: text
+#endif
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' )
+      n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
+
+      if( debug )then
+          call SYSTEM_CLOCK(tick)
+          write( stdout(),'(a,i18,a,i5,a,2i5,2i8)' )&
+               'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length
+      end if
+
+      if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) &
+           call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' )
+
+      if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#ifdef use_libSMA
+      ptr = LOC(mpp_stack)
+      words = size(bdata)*size(transfer(bdata(1),word))
+      if( words.GT.mpp_stack_size )then
+          write( text, '(i8)' )words
+          call mpp_error( FATAL, 'MPP_BROADCAST user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' )
+      end if
+      mpp_stack_hwm = max( words, mpp_stack_hwm )
+      if( mpp_npes().GT.1 )then
+!dir$ IVDEP
+          do i = 1,length
+             bdata(i) = data(i)
+          end do
+          call mpp_sync(pelist) !eliminate?
+#ifdef _CRAYT90
+          call SHMEM_UDCFLUSH !invalidate data cache
+#endif
+          call SHMEM_BROADCAST_( bdata, bdata, length, from_pe, peset(n)%start, peset(n)%log2stride, peset(n)%count, sync )
+          call mpp_sync(pelist) !eliminate?
+!dir$ IVDEP
+          do i = 1,length
+             data(i) = bdata(i)
+          end do
+      end if
+#endif
+#ifdef use_libMPI
+      if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_TYPE_, from_pe, peset(n)%id, error )
+#endif
+      if( current_clock.NE.0 )call increment_current_clock( EVENT_BROADCAST, length*MPP_TYPE_BYTELEN_ )
+      return
+    end subroutine MPP_BROADCAST_
+
+    subroutine MPP_BROADCAST_SCALAR_( data, from_pe, pelist )
+      MPP_TYPE_, intent(inout) :: data
+      integer, intent(in) :: from_pe
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: data1D(1)
+#ifdef use_CRI_pointers
+      pointer( ptr, data1D )
+
+      ptr = LOC(data)
+      call MPP_BROADCAST_( data1D, 1, from_pe, pelist )
+#else
+      data1D(1) = data
+      call MPP_BROADCAST_( data1D, 1, from_pe, pelist )
+      data = data1D(1)
+#endif
+      return
+    end subroutine MPP_BROADCAST_SCALAR_
+    
+    subroutine MPP_BROADCAST_2D_( data, length, from_pe, pelist )
+!this call was originally bundled in with mpp_transmit, but that doesn't allow
+!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
+!backward compatible.
+      MPP_TYPE_, intent(inout) :: data(:,:)
+      integer, intent(in) :: length, from_pe
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: data1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, data1D )
+      ptr = LOC(data)
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+#else
+!faster than RESHAPE? length is probably redundant
+      data1D = TRANSFER( data, data1D, length )
+!      data1D = RESHAPE( data, SHAPE(data1D) )
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+      data = RESHAPE( data1D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_BROADCAST_2D_
+    
+    subroutine MPP_BROADCAST_3D_( data, length, from_pe, pelist )
+!this call was originally bundled in with mpp_transmit, but that doesn't allow
+!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
+!backward compatible.
+      MPP_TYPE_, intent(inout) :: data(:,:,:)
+      integer, intent(in) :: length, from_pe
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: data1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, data1D )
+      ptr = LOC(data)
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+#else
+!faster than RESHAPE? length is probably redundant
+      data1D = TRANSFER( data, data1D, length )
+!      data1D = RESHAPE( data, SHAPE(data1D) )
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+      data = RESHAPE( data1D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_BROADCAST_3D_
+    
+    subroutine MPP_BROADCAST_4D_( data, length, from_pe, pelist )
+!this call was originally bundled in with mpp_transmit, but that doesn't allow
+!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
+!backward compatible.
+      MPP_TYPE_, intent(inout) :: data(:,:,:,:)
+      integer, intent(in) :: length, from_pe
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: data1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, data1D )
+      ptr = LOC(data)
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+#else
+!faster than RESHAPE? length is probably redundant
+      data1D = TRANSFER( data, data1D, length )
+!      data1D = RESHAPE( data, SHAPE(data1D) )
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+      data = RESHAPE( data1D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_BROADCAST_4D_
+    
+    subroutine MPP_BROADCAST_5D_( data, length, from_pe, pelist )
+!this call was originally bundled in with mpp_transmit, but that doesn't allow
+!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
+!backward compatible.
+      MPP_TYPE_, intent(inout) :: data(:,:,:,:,:)
+      integer, intent(in) :: length, from_pe
+      integer, intent(in), optional :: pelist(:)
+      MPP_TYPE_ :: data1D(length)
+#ifdef use_CRI_pointers
+      pointer( ptr, data1D )
+      ptr = LOC(data)
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+#else
+!faster than RESHAPE? length is probably redundant
+      data1D = TRANSFER( data, data1D, length )
+!      data1D = RESHAPE( data, SHAPE(data1D) )
+      call mpp_broadcast( data1D, length, from_pe, pelist )
+      data = RESHAPE( data1D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_BROADCAST_5D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_update_domains2D.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_update_domains2D.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_update_domains2D.h	(revision 1677)
@@ -0,0 +1,1244 @@
+    subroutine MPP_UPDATE_DOMAINS_2D_( field, domain, flags )
+!updates data domain of 2D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout) :: field(:,:)
+      type(domain2D), intent(in) :: domain
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
+#ifdef use_CRI_pointers
+      pointer( ptr, field3D )
+      ptr = LOC(field)
+      call mpp_update_domains( field3D, domain, flags )
+#else
+      field3D = RESHAPE( field, SHAPE(field3D) )
+      call mpp_update_domains( field3D, domain, flags )
+      field = RESHAPE( field3D, SHAPE(field) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_2D_
+
+    subroutine MPP_UPDATE_DOMAINS_4D_( field, domain, flags )
+!updates data domain of 4D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout) :: field(:,:,:,:)
+      type(domain2D), intent(in) :: domain
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
+#ifdef use_CRI_pointers
+      pointer( ptr, field3D )
+      ptr = LOC(field)
+      call mpp_update_domains( field3D, domain, flags )
+#else
+      field3D = RESHAPE( field, SHAPE(field3D) )
+      call mpp_update_domains( field3D, domain, flags )
+      field = RESHAPE( field3D, SHAPE(field) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_4D_
+
+    subroutine MPP_UPDATE_DOMAINS_5D_( field, domain, flags )
+!updates data domain of 5D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
+      type(domain2D), intent(in) :: domain
+      integer, intent(in), optional :: flags
+      MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
+#ifdef use_CRI_pointers
+      pointer( ptr, field3D )
+      ptr = LOC(field)
+      call mpp_update_domains( field3D, domain, flags )
+#else
+      field3D = RESHAPE( field, SHAPE(field3D) )
+      call mpp_update_domains( field3D, domain, flags )
+      field = RESHAPE( field3D, SHAPE(field) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_5D_
+
+    subroutine MPP_UPDATE_DOMAINS_3D_( field, domain, flags )
+!updates data domain of 3D field whose computational domains have been computed
+      type(domain2D), intent(in) :: domain
+      MPP_TYPE_, intent(inout) :: field(domain%x%data%begin:,domain%y%data%begin:,:)
+      integer, intent(in), optional :: flags
+      integer :: update_flags
+!equate to mpp_domains_stack
+      integer :: wordlen        !#words of MPP_TYPE_ fit in 1 word of mpp_domains_stack
+      MPP_TYPE_ :: buffer(size(mpp_domains_stack))
+#ifdef use_CRI_pointers
+      pointer( ptr, buffer )
+#endif
+      integer :: buffer_pos
+      integer :: i, j, k, m, n
+      integer :: is, ie, js, je, ke
+!receive domains saved here for unpacking
+!for non-blocking version, could be recomputed
+      integer, dimension(8) :: isr, ier, jsr, jer
+      integer :: to_pe, from_pe, list, pos, msgsize
+      logical :: recv_e, recv_se, recv_s, recv_sw, recv_w, recv_nw, recv_n, recv_ne
+      logical :: send_e, send_se, send_s, send_sw, send_w, send_nw, send_n, send_ne
+      logical :: folded
+      character(len=8) :: text
+
+      update_flags = XUPDATE+YUPDATE   !default
+      if( PRESENT(flags) )update_flags = flags
+      recv_w = BTEST(update_flags,WEST)
+      recv_e = BTEST(update_flags,EAST)
+      recv_s = BTEST(update_flags,SOUTH)
+      recv_n = BTEST(update_flags,NORTH)
+      recv_ne = recv_e .AND. recv_n
+      recv_se = recv_e .AND. recv_s
+      recv_sw = recv_w .AND. recv_s
+      recv_nw = recv_w .AND. recv_n
+      send_w = recv_e
+      send_e = recv_w
+      send_s = recv_n
+      send_n = recv_s
+      send_ne = send_e .AND. send_n
+      send_se = send_e .AND. send_s
+      send_sw = send_w .AND. send_s
+      send_nw = send_w .AND. send_n
+      if( recv_w .AND. BTEST(domain%fold,WEST)  .AND. BTEST(grid_offset_type,EAST)  ) &
+           call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
+      if( recv_s .AND. BTEST(domain%fold,SOUTH) .AND. BTEST(grid_offset_type,NORTH) ) &
+           call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
+      if( recv_e .AND. BTEST(domain%fold,EAST)  .AND. BTEST(grid_offset_type,WEST)  ) &
+           call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
+      if( recv_n .AND. BTEST(domain%fold,NORTH) .AND. BTEST(grid_offset_type,SOUTH) ) &
+           call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
+
+
+      n = size(domain%list)
+      ke = size(field,3)
+      buffer_pos = 0        !this initialization goes away if update_domains becomes non-blocking
+#ifdef use_CRI_pointers
+      ptr = LOC(mpp_domains_stack)
+      wordlen = size(transfer(buffer(1),mpp_domains_stack))
+#endif
+!send
+      do list = 0,n-1
+         m = mod( domain%pos+list, n )
+         if( .NOT.domain%list(m)%overlap )cycle
+         call mpp_clock_begin(pack_clock)
+         to_pe = domain%list(m)%pe
+         pos = buffer_pos
+         if( send_w .AND. domain%list(m)%send_w%overlap )then
+             is = domain%list(m)%send_w%is; ie = domain%list(m)%send_w%ie
+             js = domain%list(m)%send_w%js; je = domain%list(m)%send_w%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_w_off%is; ie = domain%list(m)%send_w_off%ie
+                 js = domain%list(m)%send_w_off%js; je = domain%list(m)%send_w_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_nw .AND. domain%list(m)%send_nw%overlap )then
+             is = domain%list(m)%send_nw%is; ie = domain%list(m)%send_nw%ie
+             js = domain%list(m)%send_nw%js; je = domain%list(m)%send_nw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_nw_off%is; ie = domain%list(m)%send_nw_off%ie
+                 js = domain%list(m)%send_nw_off%js; je = domain%list(m)%send_nw_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_n .AND. domain%list(m)%send_n%overlap )then
+             is = domain%list(m)%send_n%is; ie = domain%list(m)%send_n%ie
+             js = domain%list(m)%send_n%js; je = domain%list(m)%send_n%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_n_off%is; ie = domain%list(m)%send_n_off%ie
+                 js = domain%list(m)%send_n_off%js; je = domain%list(m)%send_n_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_ne .AND. domain%list(m)%send_ne%overlap )then
+             is = domain%list(m)%send_ne%is; ie = domain%list(m)%send_ne%ie
+             js = domain%list(m)%send_ne%js; je = domain%list(m)%send_ne%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_ne_off%is; ie = domain%list(m)%send_ne_off%ie
+                 js = domain%list(m)%send_ne_off%js; je = domain%list(m)%send_ne_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_e .AND. domain%list(m)%send_e%overlap )then
+             is = domain%list(m)%send_e%is; ie = domain%list(m)%send_e%ie
+             js = domain%list(m)%send_e%js; je = domain%list(m)%send_e%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_e_off%is; ie = domain%list(m)%send_e_off%ie
+                 js = domain%list(m)%send_e_off%js; je = domain%list(m)%send_e_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_se .AND. domain%list(m)%send_se%overlap )then
+             is = domain%list(m)%send_se%is; ie = domain%list(m)%send_se%ie
+             js = domain%list(m)%send_se%js; je = domain%list(m)%send_se%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_se_off%is; ie = domain%list(m)%send_se_off%ie
+                 js = domain%list(m)%send_se_off%js; je = domain%list(m)%send_se_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_s .AND. domain%list(m)%send_s%overlap )then
+             is = domain%list(m)%send_s%is; ie = domain%list(m)%send_s%ie
+             js = domain%list(m)%send_s%js; je = domain%list(m)%send_s%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_s_off%is; ie = domain%list(m)%send_s_off%ie
+                 js = domain%list(m)%send_s_off%js; je = domain%list(m)%send_s_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         if( send_sw .AND. domain%list(m)%send_sw%overlap )then
+             is = domain%list(m)%send_sw%is; ie = domain%list(m)%send_sw%ie
+             js = domain%list(m)%send_sw%js; je = domain%list(m)%send_sw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%send_sw_off%is; ie = domain%list(m)%send_sw_off%ie
+                 js = domain%list(m)%send_sw_off%js; je = domain%list(m)%send_sw_off%je
+             end if
+             call mpp_clock_begin(pack_loop_clock)
+             do k = 1,ke
+                do j = js,je
+                   do i = is,ie
+                      pos = pos + 1
+                      buffer(pos) = field(i,j,k)
+                   end do
+                end do
+             end do
+             call mpp_clock_end(pack_loop_clock)
+         end if
+         call mpp_clock_end(pack_clock)
+         call mpp_clock_begin(send_clock)
+         msgsize = pos - buffer_pos
+         print *,'msgsize ',msgsize
+         if( msgsize.GT.0 )then
+            print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
+            print *,'pos*wordlen ',pos*wordlen
+            print *,'max ',max( mpp_domains_stack_hwm, pos*wordlen )
+            print *,'mpp_domains_stack_size ',mpp_domains_stack_size
+             mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos*wordlen )
+             if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                 write( text,'(i8)' )mpp_domains_stack_hwm
+                 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains1_stack overflow, call mpp_domains_set_stack_size(' &
+                      //trim(text)//') from all PEs.' )
+             end if
+             call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
+             buffer_pos = pos
+         end if
+         call mpp_clock_end(send_clock)
+      end do
+             
+!recv
+      do list = 0,n-1
+         m = mod( domain%pos+n-list, n )
+         if( .NOT.domain%list(m)%overlap )cycle
+         call mpp_clock_begin(recv_clock)
+         from_pe = domain%list(m)%pe
+         msgsize = 0
+         if( recv_e .AND. domain%list(m)%recv_e%overlap )then
+             is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
+             js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
+                 js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_se .AND. domain%list(m)%recv_se%overlap )then
+             is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
+             js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
+                 js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_s .AND. domain%list(m)%recv_s%overlap )then
+             is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
+             js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
+                 js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
+             is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
+             js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
+                 js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_w .AND. domain%list(m)%recv_w%overlap )then
+             is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
+             js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
+                 js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
+             is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
+             js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
+                 js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_n .AND. domain%list(m)%recv_n%overlap )then
+             is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
+             js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
+                 js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
+             is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
+             js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
+                 js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
+             end if
+             msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
+         end if
+         if( msgsize.GT.0 )then
+            print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
+            print *,'buffer_pos+msgsize)*wordlen ',(buffer_pos+msgsize)*wordlen
+            print *,'max ',max( mpp_domains_stack_hwm, pos*wordlen )
+            print *,'mpp_domains_stack_size ',mpp_domains_stack_size
+             mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
+             if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                 write( text,'(i8)' )mpp_domains_stack_hwm
+                 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains2_stack overflow, call mpp_domains_set_stack_size(' &
+                      //trim(text)//') from all PEs.' )
+             end if
+             call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
+             buffer_pos = buffer_pos + msgsize
+         end if
+         call mpp_clock_end(recv_clock)
+      end do
+             
+!unpack recv
+!unpack halos in reverse order
+      do list = n-1,0,-1
+         m = mod( domain%pos+n-list, n )
+         if( .NOT.domain%list(m)%overlap )cycle
+         call mpp_clock_begin(unpk_clock)
+         from_pe = domain%list(m)%pe
+         pos = buffer_pos
+         if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
+             is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
+             js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
+                 js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_ne%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_n .AND. domain%list(m)%recv_n%overlap )then
+             is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
+             js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
+                 js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_n%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
+             is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
+             js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
+                 js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_nw%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_w .AND. domain%list(m)%recv_w%overlap )then
+             is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
+             js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
+                 js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_w%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
+             is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
+             js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
+                 js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_sw%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_s .AND. domain%list(m)%recv_s%overlap )then
+             is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
+             js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
+                 js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_s%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_se .AND. domain%list(m)%recv_se%overlap )then
+             is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
+             js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
+                 js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_se%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         if( recv_e .AND. domain%list(m)%recv_e%overlap )then
+             is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
+             js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
+             if( grid_offset_type.NE.AGRID )then
+                 is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
+                 js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
+             end if
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             pos = buffer_pos - msgsize
+             buffer_pos = pos
+             if( domain%list(m)%recv_e%folded )then
+                 do k = 1,ke
+                    do j = je,js,-1
+                       do i = ie,is,-1
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             else
+                 do k = 1,ke
+                    do j = js,je
+                       do i = is,ie
+                          pos = pos + 1
+                          field(i,j,k) = buffer(pos)
+                       end do
+                    end do
+                 end do
+             end if
+         end if
+         call mpp_clock_end(unpk_clock)
+      end do
+
+      call mpp_clock_begin(wait_clock)
+      call mpp_sync_self( domain%list(:)%pe )
+      call mpp_clock_end(wait_clock)
+      return
+    end subroutine MPP_UPDATE_DOMAINS_3D_
+
+    subroutine MPP_REDISTRIBUTE_2D_( domain_in, field_in, domain_out, field_out )
+      type(domain2D), intent(in) :: domain_in, domain_out
+      MPP_TYPE_, intent(in)  :: field_in (:,:)
+      MPP_TYPE_, intent(out) :: field_out(:,:)
+      MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),1)
+      MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),1)
+#ifdef use_CRI_pointers
+      pointer( ptr_in,  field3D_in  )
+      pointer( ptr_out, field3D_out )
+      ptr_in  = LOC(field_in )
+      ptr_out = LOC(field_out)
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+#else
+      field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+      field_out = RESHAPE( field3D_out, SHAPE(field_out) )
+#endif
+      return
+    end subroutine MPP_REDISTRIBUTE_2D_
+
+    subroutine MPP_REDISTRIBUTE_3D_( domain_in, field_in, domain_out, field_out )
+      type(domain2D), intent(in) :: domain_in, domain_out
+!      MPP_TYPE_, intent(in)  :: field_in ( domain_in%x%data%begin:, domain_in%y%data%begin:,:)
+!      MPP_TYPE_, intent(out) :: field_out(domain_out%x%data%begin:,domain_out%y%data%begin:,:)
+      MPP_TYPE_, intent(in)  :: field_in (:,:,:)
+      MPP_TYPE_, intent(out) :: field_out(:,:,:)
+      integer :: is, ie, js, je, ke, isc, iec, jsc, jec
+      integer :: i, j, k
+      integer :: list, m, n, pos, msgsize
+      integer :: to_pe, from_pe
+!      MPP_TYPE_, dimension(domain_in%x%compute%size*domain_in%y%compute%size*size(field_in,3)) :: send_buf, recv_buf
+      MPP_TYPE_ :: buffer(size(mpp_domains_stack))
+#ifdef use_CRI_pointers
+      pointer( ptr, buffer )
+#endif
+      integer :: buffer_pos, wordlen
+      character(len=8) :: text
+
+!      ke = size(field_in,3)
+!      if( ke.NE.size(field_out,3) )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
+!      if( UBOUND(field_in,1).NE.domain_in%x%data%end .OR. &
+!          UBOUND(field_in,2).NE.domain_in%y%data%end ) &
+!          call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
+!      if( UBOUND(field_out,1).NE.domain_out%x%data%end .OR. &
+!          UBOUND(field_out,2).NE.domain_out%y%data%end ) &
+!          call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
+
+!fix ke
+      ke = 0
+      if( domain_in%pe.NE.NULL_PE )ke = size(field_in,3)
+      if( domain_out%pe.NE.NULL_PE )then
+          if( ke.NE.0 .AND. ke.NE.size(field_out,3) ) &
+               call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
+          ke = size(field_out,3)
+      end if
+      if( ke.EQ.0 )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: either domain_in or domain_out must be native.' )
+!check sizes
+      if( domain_in%pe.NE.NULL_PE )then
+          if( size(field_in,1).NE.domain_in%x%data%size .OR. size(field_in,2).NE.domain_in%y%data%size ) &
+               call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
+      end if
+      if( domain_out%pe.NE.NULL_PE )then
+          if( size(field_out,1).NE.domain_out%x%data%size .OR. size(field_out,2).NE.domain_out%y%data%size ) &
+               call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
+      end if
+
+      buffer_pos = 0
+#ifdef use_CRI_pointers
+      ptr = LOC(mpp_domains_stack)
+      wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
+#endif
+!send
+      call mpp_get_compute_domain( domain_in, isc, iec, jsc, jec )
+      n = size(domain_out%list)
+      do list = 0,n-1
+         m = mod( domain_out%pos+list+n, n )
+         to_pe = domain_out%list(m)%pe
+         call mpp_get_compute_domain( domain_out%list(m), is, ie, js, je )
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
+             if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                 write( text,'(i8)' )mpp_domains_stack_hwm
+                 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
+                      //trim(text)//') from all PEs.' )
+             end if
+             pos = buffer_pos
+             do k = 1,ke
+                do j = js-domain_in%y%data%begin+1,je-domain_in%y%data%begin+1
+                   do i = is-domain_in%x%data%begin+1,ie-domain_in%x%data%begin+1
+                      pos = pos+1
+                      buffer(pos) = field_in(i,j,k)
+                   end do
+                end do
+             end do
+             if( debug )write( stderr(),* )'PE', pe, ' to PE ', to_pe, 'is,ie,js,je=', is, ie, js, je
+             call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
+             buffer_pos = pos
+         end if
+      end do
+!recv
+      call mpp_get_compute_domain( domain_out, isc, iec, jsc, jec )
+      n = size(domain_in%list)
+      do list = 0,n-1
+         m = mod( domain_in%pos+n-list, n )
+         from_pe = domain_in%list(m)%pe
+         call mpp_get_compute_domain( domain_in%list(m), is, ie, js, je )
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             msgsize = (ie-is+1)*(je-js+1)*ke
+             mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
+             if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                 write( text,'(i8)' )mpp_domains_stack_hwm
+                 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
+                      //trim(text)//') from all PEs.' )
+             end if
+             if( debug )write( stderr(),* )'PE', pe, ' from PE ', from_pe, 'is,ie,js,je=', is, ie, js, je
+             call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
+             pos = buffer_pos
+             do k = 1,ke
+                do j = js-domain_out%y%data%begin+1,je-domain_out%y%data%begin+1
+                   do i = is-domain_out%x%data%begin+1,ie-domain_out%x%data%begin+1
+                      pos = pos+1
+                      field_out(i,j,k) = buffer(pos)
+                   end do
+                end do
+             end do
+             buffer_pos = pos
+         end if
+      end do
+
+!      call mpp_sync_self( domain_in%list(:)%pe )
+      call mpp_sync_self()
+      return
+    end subroutine MPP_REDISTRIBUTE_3D_
+
+    subroutine MPP_REDISTRIBUTE_4D_( domain_in, field_in, domain_out, field_out )
+      type(domain2D), intent(in) :: domain_in, domain_out
+      MPP_TYPE_, intent(in)  :: field_in (:,:,:,:)
+      MPP_TYPE_, intent(out) :: field_out(:,:,:,:)
+      MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)*size(field_in ,4))
+      MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4))
+#ifdef use_CRI_pointers
+      pointer( ptr_in,  field3D_in  )
+      pointer( ptr_out, field3D_out )
+      ptr_in  = LOC(field_in )
+      ptr_out = LOC(field_out)
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+#else
+      field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+      field_out = RESHAPE( field3D_out, SHAPE(field_out) )
+#endif
+      return
+    end subroutine MPP_REDISTRIBUTE_4D_
+
+    subroutine MPP_REDISTRIBUTE_5D_( domain_in, field_in, domain_out, field_out )
+      type(domain2D), intent(in) :: domain_in, domain_out
+      MPP_TYPE_, intent(in)  :: field_in (:,:,:,:,:)
+      MPP_TYPE_, intent(out) :: field_out(:,:,:,:,:)
+      MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)*size(field_in ,4)*size(field_in ,5))
+      MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4)*size(field_out,5))
+#ifdef use_CRI_pointers
+      pointer( ptr_in,  field3D_in  )
+      pointer( ptr_out, field3D_out )
+      ptr_in  = LOC(field_in )
+      ptr_out = LOC(field_out)
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+#else
+      field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
+      call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
+      field_out = RESHAPE( field3D_out, SHAPE(field_out) )
+#endif
+      return
+    end subroutine MPP_REDISTRIBUTE_5D_
+#ifdef VECTOR_FIELD_
+!VECTOR_FIELD_ is set to false for MPP_TYPE_ integer or logical.
+!vector fields
+    subroutine MPP_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype )
+!updates data domain of 2D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout), dimension(:,:) :: fieldx, fieldy
+      type(domain2D), intent(inout) :: domain
+      integer, intent(in), optional :: flags, gridtype
+      MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
+      MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
+#ifdef use_CRI_pointers
+      pointer( ptrx, field3Dx )
+      pointer( ptry, field3Dy )
+      ptrx = LOC(fieldx)
+      ptry = LOC(fieldy)
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+#else
+      field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
+      field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+      fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
+      fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_2D_V_
+
+    subroutine MPP_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype )
+!updates data domain of 3D field whose computational domains have been computed
+      type(domain2D), intent(inout) :: domain
+      MPP_TYPE_, intent(inout), dimension(domain%x%data%begin:,domain%y%data%begin:,:) :: fieldx, fieldy
+      integer, intent(in), optional :: flags, gridtype
+      integer :: update_flags
+      integer :: i,j,k,n, is, ie, js, je, ke, pos
+      integer :: ioff, joff
+      MPP_TYPE_ :: buffer(size(mpp_domains_stack))
+#ifdef use_CRI_pointers
+      pointer( ptr, buffer )
+      MPP_TYPE_ :: field(size(fieldx,1),size(fieldx,2),2*size(fieldx,3))
+      pointer( ptrf, field )
+#endif
+      integer :: buffer_pos, msgsize, wordlen
+      character(len=8) :: text
+
+!gridtype
+      grid_offset_type = AGRID
+      if( PRESENT(gridtype) )then
+          if( gridtype.NE.AGRID .AND. &
+              gridtype.NE.BGRID_NE .AND. gridtype.NE.BGRID_SW .AND. &
+              gridtype.NE.CGRID_NE .AND. gridtype.NE.CGRID_SW ) &
+               call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype must be one of AGRID|BGRID_NE|BGRID_SW|CGRID_NE|CGRID_SW.' )
+!grid_offset_type used by update domains to determine shifts.
+          grid_offset_type = gridtype
+          call compute_overlaps(domain)
+          if( grid_offset_type.NE.domain%gridtype ) &
+               call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype cannot be changed during run.' )
+      end if
+!need to add code for EWS boundaries
+      if( BTEST(domain%fold,WEST) .AND. BTEST(update_flags,WEST) ) &
+           call mpp_error( FATAL, 'velocity stencil not yet active for WEST fold, contact author.' )
+      if( BTEST(domain%fold,EAST) .AND. BTEST(update_flags,EAST) ) &
+           call mpp_error( FATAL, 'velocity stencil not yet active for EAST fold, contact author.' )
+      if( BTEST(domain%fold,SOUTH) .AND. BTEST(update_flags,SOUTH) ) &
+           call mpp_error( FATAL, 'velocity stencil not yet active for SOUTH fold, contact author.' )
+
+#ifdef use_CRI_pointers
+!optimization for BGRID when fieldx and fieldy are contiguous
+      ptrf = LOC(fieldx)
+      if( LOC(field(1,1,size(fieldx,3)+1)).EQ.LOC(fieldy) .AND. &
+           ( domain%gridtype.EQ.BGRID_NE .OR. domain%gridtype.EQ.BGRID_SW ) )then
+          call mpp_update_domains( field, domain, flags )
+      else
+          call mpp_update_domains( fieldx, domain, flags )
+          call mpp_update_domains( fieldy, domain, flags )
+      end if
+#else
+      call mpp_update_domains( fieldx, domain, flags )
+      call mpp_update_domains( fieldy, domain, flags )
+#endif
+
+#ifdef use_CRI_pointers
+      ptr = LOC(mpp_domains_stack)
+#endif
+      wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
+      buffer_pos = 0
+!for all gridtypes
+      update_flags = XUPDATE+YUPDATE   !default
+      if( PRESENT(flags) )update_flags = flags
+      ke = size(fieldx,3)
+      call mpp_get_global_domain( domain, xsize=ioff, ysize=joff )
+!northern boundary fold
+      if( BTEST(domain%fold,NORTH) .AND. BTEST(update_flags,NORTH) )then
+          js = domain%y%global%end + 1
+          je = domain%y%data%end
+          if( je.GE.js )then
+!on offset grids, we need to move data leftward by one point
+              pos = domain%x%pos - 1 !the one on your left
+              if( pos.GE.0 )then
+                  is = domain%x%list(pos)%data%end+1; ie=is
+              else if( domain%x%cyclic )then
+                  pos = pos + size(domain%x%list)
+                  is = domain%x%list(pos)%data%end+1 - ioff; ie=is
+              else
+                  is=1; ie=0
+              end if
+              n = buffer_pos
+              if( ie.EQ.is )then
+                  msgsize = (je-js+1)*ke*2 !only half this on CGRID actually
+                  mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
+                  if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                      write( text,'(i8)' )mpp_domains_stack_hwm
+                      call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
+                           //trim(text)//') from all PEs.' )
+                  end if
+                  select case(grid_offset_type)
+                  case(BGRID_NE)
+                      do k = 1,ke
+                         do j = js,je
+                            n = n + 2
+                            buffer(n-1) = fieldx(is,j,k)
+                            buffer(n  ) = fieldy(is,j,k)
+                         end do
+                      end do
+                      call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
+                      buffer_pos = buffer_pos + n
+                  case(CGRID_NE)
+                      do k = 1,ke
+                         do j = js,je
+                            n = n + 1
+                            buffer(n) = fieldx(is,j,k)
+                         end do
+                      end do
+                      call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
+                      buffer_pos = buffer_pos + n
+                  end select
+!receive data at x%data%end
+                  pos = domain%x%pos + 1 !the one on your right
+                  if( pos.LT.size(domain%x%list) )then
+                      n = (je-js+1)*ke
+                  else if( domain%x%cyclic )then
+                      pos = pos - size(domain%x%list)
+                      n = (je-js+1)*ke
+                  else
+                      n = 0
+                  end if
+                  if( n.GT.0 )then
+                      mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+n)*wordlen )
+                      if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
+                          write( text,'(i8)' )mpp_domains_stack_hwm
+                          call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
+                               //trim(text)//') from all PEs.' )
+                      end if
+                      select case(grid_offset_type)
+                      case(BGRID_NE)
+                          do k = 1,ke
+                             do j = js,je
+                                do i = domain%x%data%begin,domain%x%data%end-1
+                                   fieldx(i,j,k) = fieldx(i+1,j,k)
+                                   fieldy(i,j,k) = fieldy(i+1,j,k)
+                                end do
+                             end do
+                          end do
+                          n = n*2
+                          call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
+                          i = domain%x%data%end
+                          n = buffer_pos
+                          do k = 1,ke
+                             do j = js,je
+                                n = n + 2
+                                fieldx(i,j,k) = buffer(n-1)
+                                fieldy(i,j,k) = buffer(n  )
+                             end do
+                          end do
+                      case(CGRID_NE)
+                          do k = 1,ke
+                             do j = js,je
+                                do i = domain%x%data%begin,domain%x%data%end-1
+                                   fieldx(i,j,k) = fieldx(i+1,j,k)
+                                   fieldy(i,j,k) = fieldy(i+1,j,k)
+                                end do
+                             end do
+                          end do
+                          call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
+                          i = domain%x%data%end
+                          n = buffer_pos
+                          do k = 1,ke
+                             do j = js,je
+                                n = n + 1
+                                fieldx(i,j,k) = buffer(n)
+                             end do
+                          end do
+                      end select
+                  end if
+              end if
+!flip the sign
+              is = domain%x%data%begin
+              ie = domain%x%data%end
+              do k = 1,ke
+                 do j = js,je
+                    do i = is,ie
+                       fieldx(i,j,k) = -fieldx(i,j,k)
+                       fieldy(i,j,k) = -fieldy(i,j,k)
+                    end do
+                 end do
+              end do
+          end if
+!eliminate redundant vector data at fold
+          j = domain%y%global%end
+          if( domain%y%data%begin.LE.j .AND. j.LE.domain%y%data%end )then !fold is within domain
+!ship left-half data to right half: on BGRID_NE the x%data%end point is not in mirror domain and must be done separately.
+              if( domain%x%pos.LT.(size(domain%x%list)+1)/2 )then
+                  is = domain%x%data%begin
+                  ie = min(domain%x%data%end,(domain%x%global%begin+domain%x%global%end)/2)
+                  n = buffer_pos
+                  select case(grid_offset_type)
+                  case(BGRID_NE)
+                      do k = 1,ke
+                         do i = is,ie-1
+                            n = n + 2
+                            buffer(n-1) = fieldx(i,j,k)
+                            buffer(n)   = fieldy(i,j,k)
+                         end do
+                      end do
+                      call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
+                      buffer_pos = n
+                  case(CGRID_NE)
+                      do k = 1,ke
+                         do i = is,ie
+                            n = n + 1
+                            buffer(n) = fieldy(i,j,k)
+                         end do
+                      end do
+                      call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
+                      buffer_pos = n
+                  end select
+              end if
+              if( domain%x%pos.GE.size(domain%x%list)/2 )then
+                  is = max(domain%x%data%begin,(domain%x%global%begin+domain%x%global%end)/2+1)
+                  ie = domain%x%data%end
+                  select case(grid_offset_type)
+                  case(BGRID_NE)
+                      n = (ie-is+1)*ke*2
+                      call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
+                      n = buffer_pos
+!get all values except at x%data%end
+                      do k = 1,ke
+                         do i = ie-1,is,-1
+                            n = n + 2
+                            fieldx(i,j,k) = -buffer(n-1)
+                            fieldy(i,j,k) = -buffer(n)
+                         end do
+                      end do
+!now get the value at domain%x%data%end
+                      pos = domain%x%pos - 1
+                      if( pos.GE.size(domain%x%list)/2 )then
+                          i = domain%x%list(pos)%data%end
+                          buffer_pos = n
+                          do k = 1,ke
+                             n = n + 2
+                             buffer(n-1) = fieldx(i,j,k)
+                             buffer(n  ) = fieldy(i,j,k)
+                          end do
+                          call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(pos)%pe )
+                          buffer_pos = n
+                      end if
+                      pos = domain%x%pos + 1
+                      if( pos.LT.size(domain%x%list) )then
+                          n = ke*2
+                          call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
+                          n = buffer_pos
+                          i = domain%x%data%end
+                          do k = 1,ke
+                             n = n + 2
+                             fieldx(i,j,k) = buffer(n-1)
+                             fieldy(i,j,k) = buffer(n  )
+                          end do
+                      end if
+                  case(CGRID_NE)
+                      n = (ie-is+1)*ke
+                      call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
+                      n = buffer_pos
+                      do k = 1,ke
+                         do i = ie,is,-1
+                            n = n + 1
+                            fieldy(i,j,k) = -buffer(n)
+                         end do
+                      end do
+                  end select
+              end if
+!poles set to 0: BGRID only
+              if( grid_offset_type.EQ.BGRID_NE )then
+                  do i = domain%x%global%begin-1,domain%x%global%end,(domain%x%global%begin+domain%x%global%end)/2
+                     if( domain%x%data%begin.LE.i .AND. i.LE.domain%x%data%end )then
+                         do k = 1,ke
+                            fieldx(i,j,k) = 0.
+                            fieldy(i,j,k) = 0.
+                         end do
+                     end if
+                  end do
+              end if
+!these last three code blocks correct an error where the data in your halo coming from other half may have the wrong sign
+!off west edge
+              select case(grid_offset_type)
+              case(BGRID_NE)
+                  is = domain%x%global%begin - 1
+                  if( is.GT.domain%x%data%begin )then
+                      if( 2*is-domain%x%data%begin.GT.domain%x%data%end ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE west edge ubound error.' )
+                      do k = 1,ke
+                         do i = domain%x%data%begin,is-1
+                            fieldx(i,j,k) = fieldx(2*is-i,j,k)
+                            fieldy(i,j,k) = fieldy(2*is-i,j,k)
+                         end do
+                      end do
+                  end if
+              case(CGRID_NE)
+                  is = domain%x%global%begin
+                  if( is.GT.domain%x%data%begin )then
+                      if( 2*is-domain%x%data%begin-1.GT.domain%x%data%end ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE west edge ubound error.' )
+                      do k = 1,ke
+                         do i = domain%x%data%begin,is-1
+                            fieldy(i,j,k) = fieldy(2*is-i-1,j,k)
+                         end do
+                      end do
+                  end if
+              end select
+!right of midpoint
+              is = (domain%x%global%begin+domain%x%global%end)/2
+              if( domain%x%compute%begin.LE.is .AND. is.LT.domain%x%data%end )then
+                  select case(grid_offset_type)
+                  case(BGRID_NE)
+                      ie = domain%x%data%end
+                      if( 2*is-ie.LT.domain%x%data%begin )ie = ie - 1
+                      if( 2*is-ie.LT.domain%x%data%begin ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE midpoint lbound error.' )
+                      do k = 1,ke
+                         do i = is+1,ie
+                            fieldx(i,j,k) = -fieldx(2*is-i,j,k)
+                            fieldy(i,j,k) = -fieldy(2*is-i,j,k)
+                         end do
+                      end do
+                  case(CGRID_NE)
+                      if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE midpoint lbound error.' )
+                     do k = 1,ke
+                         do i = is+1,domain%x%data%end
+                            fieldy(i,j,k) = -fieldy(2*is-i+1,j,k)
+                         end do
+                      end do
+                  end select
+              end if
+!off east edge
+              is = domain%x%global%end
+              if( is.LT.domain%x%data%end )then
+                  select case(grid_offset_type)
+                  case(BGRID_NE)
+                      if( 2*is-domain%x%data%end.LT.domain%x%data%begin ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE east edge lbound error.' )
+                      do k = 1,ke
+                         do i = is+1,domain%x%data%end
+                            fieldx(i,j,k) = fieldx(2*is-i,j,k)
+                            fieldy(i,j,k) = fieldy(2*is-i,j,k)
+                         end do
+                      end do
+                  case(CGRID_NE)
+                      if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
+                           call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE east edge lbound error.' )
+                      do k = 1,ke
+                         do i = is+1,domain%x%data%end
+                            fieldy(i,j,k) = fieldy(2*is-i+1,j,k)
+                         end do
+                      end do
+                  end select
+              end if
+          end if
+      end if
+
+      grid_offset_type = AGRID  !reset
+      call mpp_sync_self()
+      return
+    end subroutine MPP_UPDATE_DOMAINS_3D_V_
+
+    subroutine MPP_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype )
+!updates data domain of 4D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout), dimension(:,:,:,:) :: fieldx, fieldy
+      type(domain2D), intent(inout) :: domain
+      integer, intent(in), optional :: flags, gridtype
+      MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
+      MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
+#ifdef use_CRI_pointers
+      pointer( ptrx, field3Dx )
+      pointer( ptry, field3Dy )
+      ptrx = LOC(fieldx)
+      ptry = LOC(fieldy)
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+#else
+      field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
+      field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+      fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
+      fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_4D_V_
+
+    subroutine MPP_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype )
+!updates data domain of 5D field whose computational domains have been computed
+      MPP_TYPE_, intent(inout), dimension(:,:,:,:,:) :: fieldx, fieldy
+      type(domain2D), intent(inout) :: domain
+      integer, intent(in), optional :: flags, gridtype
+      MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5))
+      MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5))
+#ifdef use_CRI_pointers
+      pointer( ptrx, field3Dx )
+      pointer( ptry, field3Dy )
+      ptrx = LOC(fieldx)
+      ptry = LOC(fieldy)
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+#else
+      field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
+      field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
+      call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
+      fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
+      fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
+#endif
+      return
+    end subroutine MPP_UPDATE_DOMAINS_5D_V_
+#endif /* VECTOR_FIELD_ */
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write.h	(revision 1677)
@@ -0,0 +1,9 @@
+    subroutine MPP_WRITE_( unit, field, data, tstamp )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      MPP_TYPE_, intent(in) :: data MPP_RANK_
+      real(DOUBLE_KIND), intent(in), optional :: tstamp
+
+      MPP_WRITE_RECORD_
+      return
+    end subroutine MPP_WRITE_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write_2Ddecomp.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write_2Ddecomp.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_write_2Ddecomp.h	(revision 1677)
@@ -0,0 +1,91 @@
+subroutine MPP_WRITE_2DDECOMP_1D_( unit, field, domain, data, tstamp )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(inout) :: domain
+      MPP_TYPE_, intent(inout) :: data(:)
+      real(DOUBLE_KIND), intent(in), optional :: tstamp
+      integer::il_xbegin,il_xend,il_ybegin,il_yend,ij
+      MPP_TYPE_,allocatable :: data3D(:,:,:)
+      call mpp_get_compute_domain(domain &
+                                ,xbegin=il_xbegin,xend=il_xend &
+                                ,ybegin=il_ybegin,yend=il_yend)
+      allocate(data3D(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1,1:1))
+      data3D = RESHAPE( data, SHAPE(data3D) )
+      call mpp_write( unit, field, domain, data3D, tstamp )
+      data   = RESHAPE( data3D, SHAPE(data) )
+      deallocate(data3D)
+
+      return
+    end subroutine MPP_WRITE_2DDECOMP_1D_
+
+    subroutine MPP_WRITE_2DDECOMP_2D_( unit, field, domain, data, tstamp )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(inout) :: domain
+      MPP_TYPE_, intent(inout) :: data(:,:)
+      real(DOUBLE_KIND), intent(in), optional :: tstamp
+      MPP_TYPE_ :: data3D(size(data,1),size(data,2),1)
+#ifdef use_CRI_pointers
+      pointer( ptr, data3D )
+      ptr = LOC(data)
+      call mpp_write( unit, field, domain, data3D, tstamp )
+#else
+      data3D = RESHAPE( data, SHAPE(data3D) )
+      call mpp_write( unit, field, domain, data3D, tstamp )
+      data   = RESHAPE( data3D, SHAPE(data) )
+#endif
+      return
+    end subroutine MPP_WRITE_2DDECOMP_2D_
+
+    subroutine MPP_WRITE_2DDECOMP_3D_( unit, field, domain, data, tstamp )
+!mpp_write writes <data> which has the domain decomposition <domain>
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      type(domain2D), intent(inout) :: domain !must have intent(out) as well because active domain might be reset
+      MPP_TYPE_, intent(inout) :: data(:,:,:)
+      real(DOUBLE_KIND), intent(in), optional :: tstamp
+!cdata is used to store compute domain as contiguous data
+!gdata is used to globalize data for multi-PE single-threaded I/O
+      MPP_TYPE_, allocatable, dimension(:,:,:) :: cdata, gdata
+!NEW: data may be on compute OR data domain
+      logical :: data_has_halos, halos_are_global, x_is_global, y_is_global
+      integer :: is, ie, js, je, isd, ied, jsd, jed, isg, ieg, jsg, jeg
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_WRITE: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE: invalid unit number.' )
+      call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
+      call mpp_get_data_domain   ( domain, isd, ied, jsd, jed, x_is_global=x_is_global, y_is_global=y_is_global )
+      call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg )
+      if( size(data,1).EQ.ie-is+1 .AND. size(data,2).EQ.je-js+1 )then
+          data_has_halos = .FALSE.
+      else if( size(data,1).EQ.ied-isd+1 .AND. size(data,2).EQ.jed-jsd+1 )then
+          data_has_halos = .TRUE.
+      else
+          call mpp_error( FATAL, 'MPP_WRITE: data must be either on compute domain or data domain.' )
+      end if
+      halos_are_global = x_is_global .AND. y_is_global
+      if( npes.GT.1 .AND. mpp_file(unit)%threading.EQ.MPP_SINGLE )then
+          if( halos_are_global )then
+              call mpp_update_domains( data, domain )
+!all non-0 PEs have passed their data to PE 0 and may now exit
+              if( pe.NE.0 )return
+              call write_record( unit, field, size(data), data, tstamp )
+          else
+!put field onto global domain
+              allocate( gdata(isg:ieg,jsg:jeg,size(data,3)) )
+              call mpp_global_field( domain, data, gdata )
+!all non-0 PEs have passed their data to PE 0 and may now exit
+              if( pe.NE.0 )return
+              call write_record( unit, field, size(gdata), gdata, tstamp )
+          end if
+      else if( data_has_halos )then
+!store compute domain as contiguous data and pass to write_record
+          allocate( cdata(is:ie,js:je,size(data,3)) )
+          cdata(:,:,:) = data(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1,:)
+          call write_record( unit, field, size(cdata), cdata, tstamp, domain )
+      else
+!data is already contiguous
+          call write_record( unit, field, size(data), data, tstamp, domain )
+      end if
+      return
+    end subroutine MPP_WRITE_2DDECOMP_3D_
Index: CPL/oasis3/trunk/src/lib/mpp_io/include/os.h
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/include/os.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/include/os.h	(revision 1677)
@@ -0,0 +1,83 @@
+#ifdef __sgi
+#ifdef _COMPILER_VERSION
+!the MIPSPro compiler defines _COMPILER_VERSION
+#define sgi_mipspro
+#else
+#define sgi_generic
+#endif
+#endif
+
+#if defined(sgi_mipspro)
+#define SGICRAY
+#endif
+
+#if defined(sgi_mipspro)
+#define SGICRAY_MPP
+#endif
+
+!most compilers support Cray pointers
+!if you find a compiler that doesn't, #undef this inside a suitable #ifdef
+#define use_CRI_pointers
+
+#if defined __SX || defined __SXdbl4
+#undef use_CRI_pointers
+#else
+#define use_CRI_pointers
+#endif
+
+#ifdef __SXdbl4
+#define no_4byte_reals
+#define no_4byte_cmplx
+#define NF_GET_VAR_REAL nf_get_var_double
+#define NF_GET_VARA_REAL nf_get_vara_double
+#define NF_GET_ATT_REAL nf_get_att_double
+#endif
+
+!Modifications for Oasis - next lines commented and replaced
+!values of kind: double and long are 8-byte, float and int are 4-byte
+!#if defined(SGICRAY)
+!#define DOUBLE_KIND 8
+!#define FLOAT_KIND 4
+!#define LONG_KIND 8
+!#define INT_KIND 4
+!#define SHORT_KIND 2
+!#define POINTER_KIND 4
+!#else
+!!these might be different on non-SGICRAY, I believe
+!#define DOUBLE_KIND 8
+!#define FLOAT_KIND 4
+!#define LONG_KIND 8
+!#define INT_KIND 4
+!#define SHORT_KIND 2
+!#define POINTER_KIND 8
+!#endif
+!
+!#ifdef sgi_generic
+!!this is for the Edinburgh n32/o32 compiler, which won't accept 8-byte ints at! any price
+!#define no_8byte_integers
+!#define LONG_KIND 4
+!#ENDIF
+!
+#define DOUBLE_KIND ip_double_p 
+#define FLOAT_KIND ip_single_p
+#define LONG_KIND ip_i8_p
+#define INT_KIND ip_i4_p
+#define SHORT_KIND ip_i2_p
+
+#ifdef __crayx1
+#undef use_CRI_pointers
+
+#define no_4byte_reals
+#define no_4byte_cmplx
+#define  __no_8byte_integers
+#define NF_GET_VAR_REAL nf_get_var_double
+#define NF_GET_VARA_REAL nf_get_vara_double
+#define NF_GET_ATT_REAL nf_get_att_double
+
+!
+#define DOUBLE_KIND ip_double_p 
+#define FLOAT_KIND ip_single_p
+#define LONG_KIND ip_i8_p
+#define INT_KIND ip_i4_p
+#define SHORT_KIND ip_i4_p
+#endif
Index: CPL/oasis3/trunk/src/lib/mpp_io/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/src/Makefile	(revision 1677)
@@ -0,0 +1,53 @@
+
+SRCS1 =  $(shell ls ../../../../src/lib/mpp_io/src/*.F90)
+OBJS1 =  $(patsubst ../../../../src/lib/mpp_io/src/%.F90, %.o, $(SRCS1))
+
+SRCS5 =  $(shell ls ../../../../src/lib/mpp_io/src/*.c)
+OBJS5 =  $(patsubst ../../../../src/lib/mpp_io/src/%.c, %.o, $(SRCS5))
+
+VPATH =	../../../../src/lib/mpp_io/src:../../../../src/lib/mpp_io/include:../../../../src/lib/psmile/src:
+
+LIBRARY	= ../../../lib/libmpp_io.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS1) $(OBJS5)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS1) $(OBJS5)
+
+INCLS 	= -I../../../../src/lib/mpp_io/include
+
+INCLSC	= -I../../../../src/lib/mpp_io/include
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(MPPFLAGS) -Duse_netCDF $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(MPPFLAGS) -Duse_netCDF $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(MPPFLAGS) -Duse_netCDF $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(MPPFLAGS) -Duse_netCDF $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+
+#
+# ALL dependencies ...
+#
+
+mpp_mod.o: mod_kinds_model.o os.h mpp_transmit.h mpp_reduce.h mpp_sum.h mpp_chksum_int.h mpp_chksum.h
+
+mpp_domains_mod.o: mod_kinds_model.o mpp_mod.o os.h mpp_update_domains2D.h  mpp_global_reduce.h mpp_global_sum.h mpp_global_field.h
+
+mpp_io_mod.o: mod_kinds_model.o mpp_mod.o mpp_domains_mod.o os.h mpp_write_2Ddecomp.h mpp_write.h mpp_read_2Ddecomp.h
+
+nsclock.o:
Index: CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_domains_mod.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_domains_mod.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_domains_mod.F90	(revision 1677)
@@ -0,0 +1,2956 @@
+!-----------------------------------------------------------------------
+!   Domain decomposition and domain update for message-passing codes
+!
+! AUTHOR: V. Balaji (vbalaji@noaa.gov)
+!         Princeton University/GFDL
+!
+! MODIFICATIONS: Reiner Vogelsang (reiner@sgi.com)
+!
+! This program is free software; The author agrees that you can
+! redistribute and/or modify this version of the program under the
+! terms of the Lesser GNU General Public License as published
+! by the Free Software Foundation.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! Lesser GNU General Public License for more details
+! (http://www.gnu.org/copyleft/lesser.html).
+!-----------------------------------------------------------------------
+!#include <os.h>
+#if defined(_CRAYT3E) || defined(_CRAYT3D) || defined(sgi_mipspro)
+#define SGICRAY_MPP
+#endif
+!shmalloc is used on MPP SGI/Cray systems for shmem
+#if defined(use_libSMA) && defined(SGICRAY_MPP)
+#define use_shmalloc
+#endif
+
+module mpp_domains_mod
+  use mod_kinds_model
+!a generalized domain decomposition package for use with mpp_mod
+!Balaji (vb@gfdl.gov) 15 March 1999
+  use mpp_mod
+#include <os.h>
+  implicit none
+  private
+  character(len=128), private :: version= &
+       '$Id: mpp_domains_mod.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $'
+  character(len=128), private :: tagname= &
+       '$Name: ipslcm5a $'
+  character(len=128), private :: version_update_domains2D, version_global_reduce, version_global_sum, version_global_field
+
+!parameters used to define domains: these are passed to the flags argument of mpp_define_domains
+!  if data domain is to have global extent, set GLOBAL_DATA_DOMAIN
+!  if global domain has periodic boundaries, set CYCLIC_GLOBAL_DOMAIN
+!  sum flags together if more than one of the above conditions is to be met.
+  integer, parameter, private :: GLOBAL=0, CYCLIC=1
+  integer, parameter, private :: WEST=2, EAST=3, SOUTH=4, NORTH=5
+  integer, parameter, private :: SEND=1, RECV=2
+  integer, parameter, public :: GLOBAL_DATA_DOMAIN=2**GLOBAL, CYCLIC_GLOBAL_DOMAIN=2**CYCLIC
+!gridtypes
+  integer, parameter, private :: AGRID=0, BGRID=1, CGRID=2
+  integer, parameter, public :: BGRID_NE=BGRID+2**NORTH+2**EAST
+  integer, parameter, public :: BGRID_SW=BGRID+2**SOUTH+2**WEST
+  integer, parameter, public :: CGRID_NE=CGRID+2**NORTH+2**EAST
+  integer, parameter, public :: CGRID_SW=CGRID+2**SOUTH+2**WEST
+  integer, private :: grid_offset_type=AGRID
+!folds
+  integer, parameter, public :: FOLD_WEST_EDGE = 2**WEST, FOLD_EAST_EDGE = 2**EAST
+  integer, parameter, public :: FOLD_SOUTH_EDGE=2**SOUTH, FOLD_NORTH_EDGE=2**NORTH
+!update
+  integer, parameter, public :: WUPDATE=2**WEST, EUPDATE=2**EAST, SUPDATE=2**SOUTH, NUPDATE=2**NORTH
+  integer, parameter, public :: XUPDATE=WUPDATE+EUPDATE, YUPDATE=SUPDATE+NUPDATE
+!used by mpp_global_sum
+  integer, parameter, public :: BITWISE_EXACT_SUM=1
+
+  type, public :: domain_axis_spec        !type used to specify index limits along an axis of a domain
+     private
+     integer :: begin, end, size, max_size      !start, end of domain axis, size, max size in set
+     logical :: is_global       !TRUE if domain axis extent covers global domain
+  end type domain_axis_spec
+  type, public :: domain1D
+     private
+     type(domain_axis_spec) :: compute, data, global
+     logical :: cyclic
+     type(domain1D), pointer :: list(:)
+     integer :: pe              !PE to which this domain is assigned
+     integer :: pos             !position of this PE within link list, i.e domain%list(pos)%pe = pe
+  end type domain1D
+!domaintypes of higher rank can be constructed from type domain1D
+!typically we only need 1 and 2D, but could need higher (e.g 3D LES)
+!some elements are repeated below if they are needed once per domain, not once per axis
+  type, private :: rectangle
+     integer :: is, ie, js, je
+     logical :: overlap, folded
+  end type rectangle
+  type, public :: domain2D
+     private
+     type(domain1D) :: x
+     type(domain1D) :: y
+     type(domain2D), pointer :: list(:)
+     integer :: pe              !PE to which this domain is assigned
+     integer :: pos             !position of this PE within link list, i.e domain%list(pos)%pe = pe
+     integer :: fold, gridtype
+     logical :: overlap
+     type(rectangle) :: recv_e, recv_se, recv_s, recv_sw, &
+                        recv_w, recv_nw, recv_n, recv_ne
+     type(rectangle) :: send_e, send_se, send_s, send_sw, &
+                        send_w, send_nw, send_n, send_ne
+     logical :: remote_domains_initialized
+     type(rectangle) :: recv_e_off, recv_se_off, recv_s_off, recv_sw_off, &
+                        recv_w_off, recv_nw_off, recv_n_off, recv_ne_off
+     type(rectangle) :: send_e_off, send_se_off, send_s_off, send_sw_off, &
+                        send_w_off, send_nw_off, send_n_off, send_ne_off
+     logical :: remote_off_domains_initialized
+  end type domain2D
+  type(domain1D), public :: NULL_DOMAIN1D
+  type(domain2D), public :: NULL_DOMAIN2D
+
+  integer, private :: pe
+
+  integer, private :: tk
+  logical, private :: verbose=.FALSE., debug=.FALSE., domain_clocks_on=.FALSE.
+  logical, private :: module_is_initialized=.FALSE.
+  integer, parameter, public :: MPP_DOMAIN_TIME=MPP_DEBUG+1
+  integer :: send_clock=0, recv_clock=0, unpk_clock=0, wait_clock=0, pack_clock=0, pack_loop_clock=0
+
+!stack for internal buffers
+!allocated differently if use_shmalloc
+#ifdef use_shmalloc
+  real(DOUBLE_KIND), private :: mpp_domains_stack(1)
+  pointer( ptr_stack, mpp_domains_stack )
+#else
+  real(DOUBLE_KIND), private, allocatable :: mpp_domains_stack(:)
+#endif
+  integer, private :: mpp_domains_stack_size=0, mpp_domains_stack_hwm=0
+
+!used by mpp_define_domains2D_new to transmit data
+  integer :: domain_info_buf(16)
+#ifdef use_shmalloc
+  pointer( ptr_info, domain_info_buf )
+#endif
+
+!public interfaces
+
+! this interface can add halo to a no-halo domain and copy everything else.
+
+  interface mpp_copy_domains
+     module procedure mpp_copy_domains1D
+     module procedure mpp_copy_domains2D
+  end interface
+
+  interface mpp_define_domains
+     module procedure mpp_define_domains1D
+     module procedure mpp_define_domains2D
+  end interface
+
+  interface mpp_update_domains
+     module procedure mpp_update_domain2D_r8_2d
+     module procedure mpp_update_domain2D_r8_3d
+     module procedure mpp_update_domain2D_r8_4d
+     module procedure mpp_update_domain2D_r8_5d
+     module procedure mpp_update_domain2D_r8_2dv
+     module procedure mpp_update_domain2D_r8_3dv
+     module procedure mpp_update_domain2D_r8_4dv
+     module procedure mpp_update_domain2D_r8_5dv
+     module procedure mpp_update_domain2D_c8_2d
+     module procedure mpp_update_domain2D_c8_3d
+     module procedure mpp_update_domain2D_c8_4d
+     module procedure mpp_update_domain2D_c8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_update_domain2D_i8_2d
+     module procedure mpp_update_domain2D_i8_3d
+     module procedure mpp_update_domain2D_i8_4d
+     module procedure mpp_update_domain2D_i8_5d
+     module procedure mpp_update_domain2D_l8_2d
+     module procedure mpp_update_domain2D_l8_3d
+     module procedure mpp_update_domain2D_l8_4d
+     module procedure mpp_update_domain2D_l8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_update_domain2D_r4_2d
+     module procedure mpp_update_domain2D_r4_3d
+     module procedure mpp_update_domain2D_r4_4d
+     module procedure mpp_update_domain2D_r4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_update_domain2D_c4_2d
+     module procedure mpp_update_domain2D_c4_3d
+     module procedure mpp_update_domain2D_c4_4d
+     module procedure mpp_update_domain2D_c4_5d
+#endif
+     module procedure mpp_update_domain2D_i4_2d
+     module procedure mpp_update_domain2D_i4_3d
+     module procedure mpp_update_domain2D_i4_4d
+     module procedure mpp_update_domain2D_i4_5d
+     module procedure mpp_update_domain2D_l4_2d
+     module procedure mpp_update_domain2D_l4_3d
+     module procedure mpp_update_domain2D_l4_4d
+     module procedure mpp_update_domain2D_l4_5d
+#ifndef no_4byte_reals
+     module procedure mpp_update_domain2D_r4_2dv
+     module procedure mpp_update_domain2D_r4_3dv
+     module procedure mpp_update_domain2D_r4_4dv
+     module procedure mpp_update_domain2D_r4_5dv
+#endif
+
+!     module procedure mpp_update_domain1D_r8_2d
+!     module procedure mpp_update_domain1D_r8_3d
+!     module procedure mpp_update_domain1D_r8_4d
+!     module procedure mpp_update_domain1D_r8_5d
+!     module procedure mpp_update_domain1D_c8_2d
+!     module procedure mpp_update_domain1D_c8_3d
+!     module procedure mpp_update_domain1D_c8_4d
+!     module procedure mpp_update_domain1D_c8_5d
+!#ifndef no_8byte_integers
+!     module procedure mpp_update_domain1D_i8_2d
+!     module procedure mpp_update_domain1D_i8_3d
+!     module procedure mpp_update_domain1D_i8_4d
+!     module procedure mpp_update_domain1D_i8_5d
+!     module procedure mpp_update_domain1D_l8_2d
+!     module procedure mpp_update_domain1D_l8_3d
+!     module procedure mpp_update_domain1D_l8_4d
+!     module procedure mpp_update_domain1D_l8_5d
+!#endif
+!     module procedure mpp_update_domain1D_r4_2d
+!     module procedure mpp_update_domain1D_r4_3d
+!     module procedure mpp_update_domain1D_r4_4d
+!     module procedure mpp_update_domain1D_r4_5d
+!     module procedure mpp_update_domain1D_c4_2d
+!     module procedure mpp_update_domain1D_c4_3d
+!     module procedure mpp_update_domain1D_c4_4d
+!     module procedure mpp_update_domain1D_c4_5d
+!     module procedure mpp_update_domain1D_i4_2d
+!     module procedure mpp_update_domain1D_i4_3d
+!     module procedure mpp_update_domain1D_i4_4d
+!     module procedure mpp_update_domain1D_i4_5d
+!     module procedure mpp_update_domain1D_l4_2d
+!     module procedure mpp_update_domain1D_l4_3d
+!     module procedure mpp_update_domain1D_l4_4d
+!     module procedure mpp_update_domain1D_l4_5d
+  end interface
+
+  interface mpp_redistribute
+     module procedure mpp_redistribute_r8_2D
+     module procedure mpp_redistribute_r8_3D
+     module procedure mpp_redistribute_r8_4D
+     module procedure mpp_redistribute_r8_5D
+     module procedure mpp_redistribute_c8_2D
+     module procedure mpp_redistribute_c8_3D
+     module procedure mpp_redistribute_c8_4D
+     module procedure mpp_redistribute_c8_5D
+#ifndef no_8byte_integers
+     module procedure mpp_redistribute_i8_2D
+     module procedure mpp_redistribute_i8_3D
+     module procedure mpp_redistribute_i8_4D
+     module procedure mpp_redistribute_i8_5D
+     module procedure mpp_redistribute_l8_2D
+     module procedure mpp_redistribute_l8_3D
+     module procedure mpp_redistribute_l8_4D
+     module procedure mpp_redistribute_l8_5D
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_redistribute_r4_2D
+     module procedure mpp_redistribute_r4_3D
+     module procedure mpp_redistribute_r4_4D
+     module procedure mpp_redistribute_r4_5D
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_redistribute_c4_2D
+     module procedure mpp_redistribute_c4_3D
+     module procedure mpp_redistribute_c4_4D
+     module procedure mpp_redistribute_c4_5D
+#endif
+     module procedure mpp_redistribute_i4_2D
+     module procedure mpp_redistribute_i4_3D
+     module procedure mpp_redistribute_i4_4D
+     module procedure mpp_redistribute_i4_5D
+     module procedure mpp_redistribute_l4_2D
+     module procedure mpp_redistribute_l4_3D
+     module procedure mpp_redistribute_l4_4D
+     module procedure mpp_redistribute_l4_5D
+  end interface
+
+  interface mpp_global_field
+     module procedure mpp_global_field2D_r8_2d
+     module procedure mpp_global_field2D_r8_3d
+     module procedure mpp_global_field2D_r8_4d
+     module procedure mpp_global_field2D_r8_5d
+     module procedure mpp_global_field2D_c8_2d
+     module procedure mpp_global_field2D_c8_3d
+     module procedure mpp_global_field2D_c8_4d
+     module procedure mpp_global_field2D_c8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_global_field2D_i8_2d
+     module procedure mpp_global_field2D_i8_3d
+     module procedure mpp_global_field2D_i8_4d
+     module procedure mpp_global_field2D_i8_5d
+     module procedure mpp_global_field2D_l8_2d
+     module procedure mpp_global_field2D_l8_3d
+     module procedure mpp_global_field2D_l8_4d
+     module procedure mpp_global_field2D_l8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_global_field2D_r4_2d
+     module procedure mpp_global_field2D_r4_3d
+     module procedure mpp_global_field2D_r4_4d
+     module procedure mpp_global_field2D_r4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_global_field2D_c4_2d
+     module procedure mpp_global_field2D_c4_3d
+     module procedure mpp_global_field2D_c4_4d
+     module procedure mpp_global_field2D_c4_5d
+#endif
+     module procedure mpp_global_field2D_i4_2d
+     module procedure mpp_global_field2D_i4_3d
+     module procedure mpp_global_field2D_i4_4d
+     module procedure mpp_global_field2D_i4_5d
+     module procedure mpp_global_field2D_l4_2d
+     module procedure mpp_global_field2D_l4_3d
+     module procedure mpp_global_field2D_l4_4d
+     module procedure mpp_global_field2D_l4_5d
+     module procedure mpp_global_field1D_r8_2d
+     module procedure mpp_global_field1D_c8_2d
+#ifndef no_8byte_integers
+     module procedure mpp_global_field1D_i8_2d
+     module procedure mpp_global_field1D_l8_2d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_global_field1D_r4_2d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_global_field1D_c4_2d
+#endif
+     module procedure mpp_global_field1D_i4_2d
+     module procedure mpp_global_field1D_l4_2d
+  end interface
+
+  interface mpp_global_max
+     module procedure mpp_global_max_r8_2d
+     module procedure mpp_global_max_r8_3d
+     module procedure mpp_global_max_r8_4d
+     module procedure mpp_global_max_r8_5d
+#ifndef no_4byte_reals
+     module procedure mpp_global_max_r4_2d
+     module procedure mpp_global_max_r4_3d
+     module procedure mpp_global_max_r4_4d
+     module procedure mpp_global_max_r4_5d
+#endif
+#ifndef no_8byte_integers
+     module procedure mpp_global_max_i8_2d
+     module procedure mpp_global_max_i8_3d
+     module procedure mpp_global_max_i8_4d
+     module procedure mpp_global_max_i8_5d
+#endif
+     module procedure mpp_global_max_i4_2d
+     module procedure mpp_global_max_i4_3d
+     module procedure mpp_global_max_i4_4d
+     module procedure mpp_global_max_i4_5d
+  end interface
+
+  interface mpp_global_min
+     module procedure mpp_global_min_r8_2d
+     module procedure mpp_global_min_r8_3d
+     module procedure mpp_global_min_r8_4d
+     module procedure mpp_global_min_r8_5d
+#ifndef no_4byte_reals
+     module procedure mpp_global_min_r4_2d
+     module procedure mpp_global_min_r4_3d
+     module procedure mpp_global_min_r4_4d
+     module procedure mpp_global_min_r4_5d
+#endif
+#ifndef no_8byte_integers
+     module procedure mpp_global_min_i8_2d
+     module procedure mpp_global_min_i8_3d
+     module procedure mpp_global_min_i8_4d
+     module procedure mpp_global_min_i8_5d
+#endif
+     module procedure mpp_global_min_i4_2d
+     module procedure mpp_global_min_i4_3d
+     module procedure mpp_global_min_i4_4d
+     module procedure mpp_global_min_i4_5d
+  end interface
+
+  interface mpp_global_sum
+     module procedure mpp_global_sum_r8_2d
+     module procedure mpp_global_sum_r8_3d
+     module procedure mpp_global_sum_r8_4d
+     module procedure mpp_global_sum_r8_5d
+#ifndef no_4byte_reals
+     module procedure mpp_global_sum_r4_2d
+     module procedure mpp_global_sum_r4_3d
+     module procedure mpp_global_sum_r4_4d
+     module procedure mpp_global_sum_r4_5d
+#endif
+     module procedure mpp_global_sum_c8_2d
+     module procedure mpp_global_sum_c8_3d
+     module procedure mpp_global_sum_c8_4d
+     module procedure mpp_global_sum_c8_5d
+#ifndef no_4byte_cmplx
+     module procedure mpp_global_sum_c4_2d
+     module procedure mpp_global_sum_c4_3d
+     module procedure mpp_global_sum_c4_4d
+     module procedure mpp_global_sum_c4_5d
+#endif
+#ifndef no_8byte_integers
+     module procedure mpp_global_sum_i8_2d
+     module procedure mpp_global_sum_i8_3d
+     module procedure mpp_global_sum_i8_4d
+     module procedure mpp_global_sum_i8_5d
+#endif
+     module procedure mpp_global_sum_i4_2d
+     module procedure mpp_global_sum_i4_3d
+     module procedure mpp_global_sum_i4_4d
+     module procedure mpp_global_sum_i4_5d
+  end interface
+
+  interface operator(.EQ.)
+     module procedure mpp_domain1D_eq
+     module procedure mpp_domain2D_eq
+  end interface
+
+  interface operator(.NE.)
+     module procedure mpp_domain1D_ne
+     module procedure mpp_domain2D_ne
+  end interface
+
+  interface mpp_get_compute_domain
+     module procedure mpp_get_compute_domain1D
+     module procedure mpp_get_compute_domain2D
+  end interface
+
+  interface mpp_get_compute_domains
+     module procedure mpp_get_compute_domains1D
+     module procedure mpp_get_compute_domains2D
+  end interface
+
+  interface mpp_get_data_domain
+     module procedure mpp_get_data_domain1D
+     module procedure mpp_get_data_domain2D
+  end interface
+
+  interface mpp_get_global_domain
+     module procedure mpp_get_global_domain1D
+     module procedure mpp_get_global_domain2D
+  end interface
+
+  interface mpp_define_layout
+     module procedure mpp_define_layout2D
+  end interface
+
+  interface mpp_get_pelist
+     module procedure mpp_get_pelist1D
+     module procedure mpp_get_pelist2D
+  end interface
+
+  interface mpp_get_layout
+     module procedure mpp_get_layout1D
+     module procedure mpp_get_layout2D
+  end interface
+
+  public :: mpp_broadcast_domain, mpp_define_layout, mpp_define_domains, mpp_domains_init, mpp_domains_set_stack_size, &
+            mpp_domains_exit, mpp_get_compute_domain, mpp_get_compute_domains, mpp_get_data_domain, mpp_get_global_domain, &
+            mpp_get_domain_components, mpp_get_layout, mpp_get_pelist, mpp_redistribute, mpp_update_domains, &
+            mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum, operator(.EQ.), operator(.NE.), &
+            mpp_copy_domains
+
+  contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                 MPP_DOMAINS: initialization and termination                 !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_domains_init(flags)
+!initialize domain decomp package
+      integer, intent(in), optional :: flags
+      integer :: l=0
+
+      if( module_is_initialized )return
+      call mpp_init(flags)           !this is a no-op if already initialized
+      pe = mpp_pe()
+      module_is_initialized = .TRUE.
+      if( pe.EQ.mpp_root_pe() )then
+          write( stdlog(),'(/a)' )'MPP_DOMAINS module '//trim(version) &
+               //trim(tagname)
+!          write( stdlog(),'(a)' )trim(version_update_domains2D)
+      end if
+
+      if( PRESENT(flags) )then
+          debug   = flags.EQ.MPP_DEBUG
+          verbose = flags.EQ.MPP_VERBOSE .OR. debug
+          domain_clocks_on = flags.EQ.MPP_DOMAIN_TIME
+      end if
+
+      call mpp_domains_set_stack_size(983040) !default, pretty arbitrary
+#ifdef use_shmalloc
+      call mpp_malloc( ptr_info, 16, l )
+#endif
+
+!NULL_DOMAIN is a domaintype that can be used to initialize to undef
+      NULL_DOMAIN1D%global%begin  = -1; NULL_DOMAIN1D%global%end  = -1; NULL_DOMAIN1D%global%size = 0
+      NULL_DOMAIN1D%data%begin    = -1; NULL_DOMAIN1D%data%end    = -1; NULL_DOMAIN1D%data%size = 0
+      NULL_DOMAIN1D%compute%begin = -1; NULL_DOMAIN1D%compute%end = -1; NULL_DOMAIN1D%compute%size = 0
+      NULL_DOMAIN1D%pe = ANY_PE
+      NULL_DOMAIN2D%x = NULL_DOMAIN1D
+      NULL_DOMAIN2D%y = NULL_DOMAIN1D
+      NULL_DOMAIN2D%pe = ANY_PE
+
+      if( domain_clocks_on )then
+          pack_clock = mpp_clock_id( 'Halo pack' )
+          pack_loop_clock = mpp_clock_id( 'Halo pack loop' )
+          send_clock = mpp_clock_id( 'Halo send' )
+          recv_clock = mpp_clock_id( 'Halo recv' )
+          unpk_clock = mpp_clock_id( 'Halo unpk' )
+          wait_clock = mpp_clock_id( 'Halo wait' )
+      end if
+      return
+    end subroutine mpp_domains_init
+
+    subroutine mpp_domains_set_stack_size(n)
+!set the mpp_domains_stack variable to be at least n LONG words long
+      integer, intent(in) :: n
+      character(len=8) :: text
+
+      if( n.LE.mpp_domains_stack_size )return
+#ifdef use_shmalloc
+      call mpp_malloc( ptr_stack, n, mpp_domains_stack_size )
+#else
+      if( allocated(mpp_domains_stack) )deallocate(mpp_domains_stack)
+      allocate( mpp_domains_stack(n) )
+      mpp_domains_stack_size = n
+#endif
+      write( text,'(i8)' )n
+      if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, 'MPP_DOMAINS_SET_STACK_SIZE: stack size set to '//text//'.' )
+
+      return
+    end subroutine mpp_domains_set_stack_size
+
+    subroutine mpp_domains_exit()
+!currently does not have much to do, but provides the possibility of re-initialization
+      if( .NOT.module_is_initialized )return
+      call mpp_max(mpp_domains_stack_hwm)
+      if( pe.EQ.mpp_root_pe() )write( stdout(),* )'MPP_DOMAINS_STACK high water mark=', mpp_domains_stack_hwm
+      module_is_initialized = .FALSE.
+      return
+    end subroutine mpp_domains_exit
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                MPP_DOMAINS: overloaded operators (==, /=)                   !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    function mpp_domain1D_eq( a, b )
+      logical :: mpp_domain1D_eq
+      type(domain1D), intent(in) :: a, b
+
+      mpp_domain1D_eq = ( a%compute%begin.EQ.b%compute%begin .AND. &
+                          a%compute%end  .EQ.b%compute%end   .AND. &
+                          a%data%begin   .EQ.b%data%begin    .AND. &
+                          a%data%end     .EQ.b%data%end      .AND. & 
+                          a%global%begin .EQ.b%global%begin  .AND. &
+                          a%global%end   .EQ.b%global%end    )
+!compare pelists
+!      if( mpp_domain1D_eq )mpp_domain1D_eq = ASSOCIATED(a%list) .AND. ASSOCIATED(b%list)
+!      if( mpp_domain1D_eq )mpp_domain1D_eq = size(a%list).EQ.size(b%list)
+!      if( mpp_domain1D_eq )mpp_domain1D_eq = ALL(a%list%pe.EQ.b%list%pe)
+      
+      return
+    end function mpp_domain1D_eq
+
+    function mpp_domain1D_ne( a, b )
+      logical :: mpp_domain1D_ne
+      type(domain1D), intent(in) :: a, b
+
+      mpp_domain1D_ne = .NOT. ( a.EQ.b )
+      return
+    end function mpp_domain1D_ne
+
+    function mpp_domain2D_eq( a, b )
+      logical :: mpp_domain2D_eq
+      type(domain2D), intent(in) :: a, b
+
+      mpp_domain2D_eq = a%x.EQ.b%x .AND. a%y.EQ.b%y
+      if( mpp_domain2D_eq .AND. ((a%pe.EQ.ANY_PE).OR.(b%pe.EQ.ANY_PE)) )return !NULL_DOMAIN2D
+!compare pelists
+      if( mpp_domain2D_eq )mpp_domain2D_eq = ASSOCIATED(a%list) .AND. ASSOCIATED(b%list)
+      if( mpp_domain2D_eq )mpp_domain2D_eq = size(a%list).EQ.size(b%list)
+      if( mpp_domain2D_eq )mpp_domain2D_eq = ALL(a%list%pe.EQ.b%list%pe)
+      return
+    end function mpp_domain2D_eq
+
+    function mpp_domain2D_ne( a, b )
+      logical :: mpp_domain2D_ne
+      type(domain2D), intent(in) :: a, b
+
+      mpp_domain2D_ne = .NOT. ( a.EQ.b )
+      return
+    end function mpp_domain2D_ne
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!              MPP_COPY_DOMAINS: Copy domain and add halo                     !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_copy_domains1D(domain_in, domain_out, halo)
+! ARGUMENTS
+! domain_in is the input domain
+! domain_out is the returned domain
+! halo (optional) defines halo width (currently the same on both sides)
+
+      type(domain1D), intent(in)    :: domain_in
+      type(domain1D), intent(out)   :: domain_out
+      integer, intent(in), optional :: halo
+
+      integer, dimension(:), allocatable :: pelist, extent
+      integer :: ndivs, global_indices(2) !(/ isg, ieg /)
+      integer :: isg, ieg, halosz
+
+      
+! get the global indices of the input domain
+      call mpp_get_global_domain(domain_in, isg, ieg )
+      global_indices(1) = isg;       global_indices(2) = ieg
+
+! get the number of divisions of domain
+      call mpp_get_layout(domain_in, ndivs)
+
+      allocate(pelist(0:ndivs-1),extent(0:ndivs-1))
+
+! get the pe list of the input domain
+      call mpp_get_pelist( domain_in, pelist)
+
+! get the halo
+      halosz = 0
+      if(present(halo)) halosz = halo
+
+! get the extent
+      call mpp_get_compute_domains(Domain_in, size = extent(0:ndivs-1))      
+
+      call mpp_define_domains( global_indices, ndivs, domain_out, pelist = pelist, &
+                                 halo = halosz, extent = extent )
+
+    end subroutine mpp_copy_domains1D
+
+
+!----------------------------------------------------------------------------------
+
+
+    subroutine mpp_copy_domains2D(domain_in, domain_out, xhalo, yhalo)
+! ARGUMENTS
+! domain_in is the input domain
+! domain_out is the returned domain
+! xhalo, yhalo (optional) defines halo width. 
+
+      type(domain2D), intent(in)    :: domain_in
+      type(domain2D), intent(out)   :: domain_out
+      integer, intent(in), optional :: xhalo, yhalo
+
+      integer, dimension(:), allocatable :: pelist, xextent, yextent, xbegin, xend, &
+                                            xsize, ybegin, yend, ysize
+      integer :: ndivx, ndivy, ndivs, npes, global_indices(4), layout(2)
+      integer :: isg, ieg, jsg, jeg, xhalosz, yhalosz, i, j, m, n, pe
+      
+! get the global indices of the input domain
+      call mpp_get_global_domain(domain_in, isg, ieg, jsg, jeg )
+      global_indices(1) = isg;       global_indices(2) = ieg
+      global_indices(3) = jsg;       global_indices(4) = jeg
+
+! get the number of divisions of domain
+      call mpp_get_layout(domain_in, layout)
+      ndivx = layout(1); ndivy = layout(2)
+      ndivs = ndivx * ndivy
+      npes = mpp_npes()
+
+      if( ndivs.NE.npes )call mpp_error( 'mpp_domains_mod', &
+                 'mpp_copy_domains: number of PEs is not consistent with the layout', FATAL )
+      allocate(pelist(0:npes-1), xsize(0:npes-1), ysize(0:npes-1), &
+               xbegin(0:npes-1), xend(0:npes-1),                   &
+               ybegin(0:npes-1), yend(0:npes-1),                   &
+               xextent(0:ndivx), yextent(0:ndivy))
+
+! get the pe list of the input domain
+      call mpp_get_pelist2D( domain_in, pelist)
+
+! get the halo
+      xhalosz = 0; yhalosz = 0
+      if(present(xhalo)) xhalosz = xhalo
+      if(present(yhalo)) yhalosz = yhalo
+
+! get the extent
+      call mpp_get_compute_domains(Domain_in, xbegin, xend, xsize, &
+                                          ybegin, yend, ysize  )
+            
+!  compute the exact x-axis decomposition
+      i = isg
+      m = 0
+      xextent = 0
+      do pe = 0, npes-1
+        if ( xbegin(pe) == i ) then
+          m = m+1
+          xextent (m) = xsize (pe)
+          i = i + xsize(pe)
+          if ( m == size(xextent) .or. i > ieg ) exit
+        endif
+      enddo
+
+!  compute the exact y-axis decomposition
+      j = jsg 
+      n = 0   
+      yextent = 0
+      do pe = 0, npes-1
+        if ( ybegin(pe) == j ) then
+          n = n+1 
+          yextent (n) = ysize (pe)
+          j = j + ysize(pe)
+          if ( n == size(yextent) .or. j > jeg ) exit
+        endif   
+      enddo   
+
+      call mpp_define_domains( global_indices, layout, domain_out, pelist = pelist, &
+                               xhalo = xhalosz, yhalo = yhalosz, xextent = xextent, & 
+                               yextent = yextent)
+
+    end subroutine mpp_copy_domains2D
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!              MPP_DEFINE_DOMAINS: define layout and decomposition            !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_define_domains1D( global_indices, ndivs, domain, pelist, &
+                                     flags, halo, extent, maskmap,offset)
+!routine to divide global array indices among domains, and assign domains to PEs
+!domain is of type domain1D
+!ARGUMENTS:
+!      global_indices(2)=(isg,ieg) gives the extent of global domain
+!      ndivs is number of divisions of domain: even divisions unless extent is present.
+!      domain is the returned domain1D
+!      pelist (optional) list of PEs to which domains are to be assigned (default 0...npes-1)
+!                 size of pelist must correspond to number of mask=.TRUE. divisions
+!      flags define whether compute and data domains are global (undecomposed) and whether global domain has periodic boundaries
+!      halo (optional) defines halo width (currently the same on both sides)
+!      extent (optional) array defines width of each division (used for non-uniform domain decomp, for e.g load-balancing)
+!      maskmap (optional) a division whose maskmap=.FALSE. is not assigned to any domain
+!  By default we assume decomposition of compute and data domains, non-periodic boundaries, no halo, as close to uniform extents
+!  as the input parameters permit
+      integer, intent(in) :: global_indices(2) !(/ isg, ieg /)
+      integer, intent(in) :: ndivs
+      type(domain1D), intent(inout) :: domain !declared inout so that existing links, if any, can be nullified
+      integer, intent(in), optional :: pelist(0:)
+      integer, intent(in), optional :: flags, halo
+      integer, intent(in), optional :: extent(0:)
+      logical, intent(in), optional :: maskmap(0:)
+      integer, intent(in), optional :: offset(0:)
+
+      logical :: compute_domain_is_global, data_domain_is_global
+      integer :: ndiv, n, isg, ieg, is, ie, i, off, pos, hs, he
+      integer, allocatable :: pes(:)
+      logical, allocatable :: mask(:)
+!rv
+      logical ::blocks
+      integer :: lastie
+!rv
+      integer :: halosz
+!used by symmetry algorithm
+      integer :: imax, ndmax, ndmirror
+      logical :: symmetrize
+!statement functions
+      logical :: even, odd
+      even(n) = (mod(n,2).EQ.0)
+      odd (n) = (mod(n,2).EQ.1)
+      
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
+!get global indices
+      isg = global_indices(1)
+      ieg = global_indices(2)
+      if( ndivs.GT.ieg-isg+1 )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
+!get the list of PEs on which to assign domains; if pelist is absent use 0..npes-1
+      if( PRESENT(pelist) )then
+          if( .NOT.any(pelist.EQ.pe) )then
+              write( stderr(),* )'pe=', pe, ' pelist=', pelist
+              call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
+          end if
+          allocate( pes(0:size(pelist)-1) )
+          pes(:) = pelist(:)
+      else
+          allocate( pes(0:mpp_npes()-1) )
+          pes(:) = (/ (i,i=0,mpp_npes()-1) /)
+      end if
+
+!rv Block distribution ?
+      blocks=.false.
+      if(present(offset)) blocks=.true.
+      if(blocks) then
+       if((.not.present(maskmap)).and.(.not.present(extent))) &
+         call mpp_error(FATAL, 'MPP_DEFINE_DOMAINS1D: you have to define maskmap and extent!')
+        if(size(offset).ne.ndivs) &
+          call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: offset array size must equal number of domain divisions.' )
+      endif
+!rv
+!get number of real domains: 1 mask domain per PE in pes
+      allocate( mask(0:ndivs-1) )
+      mask = .TRUE.                 !default mask
+      if( PRESENT(maskmap) )then
+          if( size(maskmap).NE.ndivs ) &
+               call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
+          mask(:) = maskmap(:)
+      end if
+      if( count(mask).NE.size(pes) ) &
+           call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
+        
+      if( PRESENT(extent) )then
+          if( size(extent).NE.ndivs ) &
+               call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: extent array size must equal number of domain divisions.' )
+      end if
+!get halosize
+      halosz = 0
+      if( PRESENT(halo) )halosz = halo
+
+!get flags
+      compute_domain_is_global = .FALSE.
+      data_domain_is_global    = .FALSE.
+      domain%cyclic = .FALSE.
+      if( PRESENT(flags) )then
+!NEW: obsolete flag global_compute_domain, since ndivs is non-optional and you cannot have global compute and ndivs.NE.1 
+          compute_domain_is_global = ndivs.EQ.1
+!if compute domain is global, data domain must also be
+          data_domain_is_global    = BTEST(flags,GLOBAL) .OR. compute_domain_is_global
+          domain%cyclic  = BTEST(flags,CYCLIC) .AND. halosz.NE.0
+      end if
+
+!set up links list
+      allocate( domain%list(0:ndivs-1) )
+
+!set global domain
+      domain%list(:)%global%begin     = isg
+      domain%list(:)%global%end       = ieg
+      domain%list(:)%global%size      = ieg-isg+1
+      domain%list(:)%global%max_size  = ieg-isg+1
+      domain%list(:)%global%is_global = .TRUE. !always
+
+!get compute domain
+      if( compute_domain_is_global )then
+          domain%list(:)%compute%begin = isg
+          domain%list(:)%compute%end   = ieg
+          domain%list(:)%compute%is_global = .TRUE.
+          domain%list(:)%pe = pes(:)
+          domain%pos = 0
+      else
+          domain%list(:)%compute%is_global = .FALSE.
+          is = isg
+          lastie=-1
+          n = 0
+          do ndiv=0,ndivs-1
+             if( PRESENT(extent) )then
+!rv build the grid by individual block sizes
+               if(blocks) then
+                 if(mask(ndiv)) then
+                   is=isg+offset(ndiv)
+                   ie = is + extent(ndiv) - 1
+!                 print*,pe,':',ndiv,blocks,is,ie,ieg,offset
+                 endif
+!                 if( ndiv.EQ.ndivs-1 .AND. ie.NE.ieg ) &
+!                      call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: extent array limits do not match global domain.' )
+               else
+                 ie = is + extent(ndiv) - 1
+                 if( ndiv.EQ.ndivs-1 .AND. ie.NE.ieg ) &
+                      call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: extent array limits do not match global domain.' )
+               endif
+             else
+!modified for mirror-symmetry
+!original line
+!                 ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1
+
+!problem of dividing nx points into n domains maintaining symmetry
+!i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not.
+!this will always work for nx even n even or odd
+!this will always work for nx odd, n odd
+!this will never  work for nx odd, n even: for this case we supersede the mirror calculation
+!                 symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(ieg-isg+1,2).EQ.1 )
+!nx even n odd fails if n>nx/2
+                 symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
+                              (  odd(ndivs) .AND.  odd(ieg-isg+1) ) .OR. &
+                              (  odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
+
+!mirror domains are stored in the list and retrieved if required.
+                 if( ndiv.EQ.0 )then
+!initialize max points and max domains
+                     imax = ieg
+                     ndmax = ndivs
+                 end if
+!do bottom half of decomposition, going over the midpoint for odd ndivs
+                 if( ndiv.LT.(ndivs-1)/2+1 )then
+!domain is sized by dividing remaining points by remaining domains
+                     ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
+                     ndmirror = (ndivs-1) - ndiv !mirror domain
+                     if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
+!mirror extents, the max(,) is to eliminate overlaps
+                         domain%list(ndmirror)%compute%begin = max( isg+ieg-ie, ie+1 )
+                         domain%list(ndmirror)%compute%end   = max( isg+ieg-is, ie+1 )
+                         imax = domain%list(ndmirror)%compute%begin - 1
+                         ndmax = ndmax - 1
+                     end if
+                 else
+                     if( symmetrize )then
+!do top half of decomposition by retrieving saved values
+                         is = domain%list(ndiv)%compute%begin
+                         ie = domain%list(ndiv)%compute%end
+                     else
+                         ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
+                     end if
+                 end if
+             end if
+             if(blocks) then
+               if(mask(ndiv))then
+                 if( ie.LT.is )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: domain extents must be positive definite.' )
+                 domain%list(ndiv)%compute%begin = is
+                 domain%list(ndiv)%compute%end   = ie
+!                 if(lastie.gt.0.and.is.ne.lastie+1) &
+!                   call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: block extents do not span space completely.' )
+                 lastie=ie
+                 domain%list(ndiv)%pe = pes(n)
+                 if( pe.EQ.pes(n) )domain%pos = ndiv
+                 n = n + 1
+                 is = ie + 1
+               else
+!rv for Arnaud
+                 domain%list(ndiv)%compute%begin = 0
+                 domain%list(ndiv)%compute%end   = 0
+               endif
+               if(ndiv.eq.ndivs-1.and.lastie.gt.ieg) &
+                   call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: block extents exceed max. space.' )
+             else
+             if( ie.LT.is )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: domain extents must be positive definite.' )
+             domain%list(ndiv)%compute%begin = is
+             domain%list(ndiv)%compute%end   = ie
+             if( ndiv.GT.0 .AND. is.NE.domain%list(ndiv-1)%compute%end+1 ) &
+                  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: domain extents do not span space completely.' )
+             if( ndiv.EQ.ndivs-1 .AND. domain%list(ndiv)%compute%end.NE.ieg ) &
+                  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: domain extents do not span space completely.' )
+             if( mask(ndiv) )then
+                 domain%list(ndiv)%pe = pes(n)
+                 if( pe.EQ.pes(n) )domain%pos = ndiv
+                 n = n + 1
+             end if
+             is = ie + 1
+             endif
+          end do
+      end if
+          
+      domain%list(:)%compute%size  = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
+
+!get data domain
+!data domain is at least equal to compute domain
+      domain%list(:)%data%begin = domain%list(:)%compute%begin
+      domain%list(:)%data%end   = domain%list(:)%compute%end
+      domain%list(:)%data%is_global = .FALSE.
+!apply global flags
+      if( data_domain_is_global )then
+          domain%list(:)%data%begin  = isg
+          domain%list(:)%data%end    = ieg
+          domain%list(:)%data%is_global = .TRUE.
+      end if
+!apply margins
+      domain%list(:)%data%begin = domain%list(:)%data%begin - halosz
+      domain%list(:)%data%end   = domain%list(:)%data%end   + halosz  
+      domain%list(:)%data%size  = domain%list(:)%data%end - domain%list(:)%data%begin + 1
+
+!      domain = domain%list(pos) !load domain from domain%list(pos)
+      domain%compute = domain%list(domain%pos)%compute
+      domain%data = domain%list(domain%pos)%data
+      domain%global = domain%list(domain%pos)%global
+      domain%compute%max_size = MAXVAL( domain%list(:)%compute%size )
+      domain%data%max_size    = MAXVAL( domain%list(:)%data%size )
+      domain%global%max_size  = domain%global%size
+
+!PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
+      deallocate( pes, mask )
+      return
+
+      contains
+
+        function if_overlap( hs, he, cs, ce, os, oe )
+!function to look if a portion of the halo [hs,he] lies with in the compute region [cs,ce]
+!if yes, if_overlap returns true, and the overlap region is returned in [os,oe]
+          logical :: if_overlap
+          integer, intent(in) :: hs, he, cs, ce
+          integer, intent(out) :: os, oe
+          os = max(hs,cs)
+          oe = min(he,ce)
+          if( debug )write( stderr(),'(a,7i4)' ) &
+               'MPP_DEFINE_DOMAINS1D: pe, hs, he, cs, ce, os, oe=', pe, hs, he, cs, ce, os, oe
+          if_overlap = oe.GE.os
+          return
+        end function if_overlap
+          
+    end subroutine mpp_define_domains1D
+
+    subroutine mpp_define_domains2D( global_indices, layout, domain, pelist, &
+                                                     xflags, yflags, &
+                                     xhalo, yhalo, xextent, yextent, maskmap,offsetx,offsety, name )
+!define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,jsg:jeg) and assign them to PEs
+      integer, intent(in) :: global_indices(4) !(/ isg, ieg, jsg, jeg /)
+      integer, intent(in) :: layout(2)
+      type(domain2D), intent(inout) :: domain
+      integer, intent(in), optional :: pelist(0:)
+      integer, intent(in), optional :: xflags, yflags, xhalo, yhalo
+      integer, intent(in), optional :: xextent(0:), yextent(0:)
+      logical, intent(in), optional :: maskmap(0:,0:)
+      integer, intent(in), optional :: offsetx(0:), offsety(0:)
+      character(len=*), intent(in), optional :: name
+      integer :: i, j, m, n
+      integer :: ipos, jpos, pos
+      integer :: ndivx, ndivy, isg, ieg, jsg, jeg, isd, ied, jsd, jed
+      
+      logical, allocatable :: mask(:,:)
+!rv
+      logical :: blocks
+!rv
+      integer, allocatable :: pes(:), pearray(:,:)
+      character(len=8) :: text
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
+      ndivx = layout(1); ndivy = layout(2)
+      isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
+
+      if( PRESENT(pelist) )then
+          allocate( pes(0:size(pelist)-1) )
+          pes = pelist
+      else
+          allocate( pes(0:mpp_npes()-1) )
+          call mpp_get_current_pelist(pes)
+!          pes = (/ (i,i=0,mpp_npes()-1) /)
+      end if
+!rv Block distribution ?
+      blocks=.false.
+      if(present(offsetx).and.present(offsety)) blocks=.true.
+      if(present(offsetx).and.(.not.present(offsety))) then
+         call mpp_error(FATAL,'MPP_DEFINE_DOMAINS1D: you have to define offsetx AND offsety!')
+      endif
+      if((.not.present(offsetx)).and.present(offsety)) then
+         call mpp_error(FATAL,'MPP_DEFINE_DOMAINS1D: you have to define offsetx AND offsety!')
+      endif
+      if(blocks) then
+       if((.not.present(maskmap)).and.(.not.present(xextent))) &
+         call mpp_error(FATAL, 'MPP_DEFINE_DOMAINS1D: you have to define maskmap and xextent!')
+       if((.not.present(maskmap)).and.(.not.present(yextent))) &
+         call mpp_error(FATAL, 'MPP_DEFINE_DOMAINS1D: you have to define maskmap and yextent!')
+       if(size(offsetx).ne.ndivx) &
+         call mpp_error(FATAL,'MPP_DEFINE_DOMAINS2D: offsetx array does not match layout!')
+       if(size(offsety).ne.ndivy) &
+         call mpp_error(FATAL,'MPP_DEFINE_DOMAINS2D: offsety array does not match layout!')
+      endif
+!rv
+
+      allocate( mask(0:ndivx-1,0:ndivy-1) )
+      mask = .TRUE.
+      if( PRESENT(maskmap) )then
+          if( size(maskmap,1).NE.ndivx .OR. size(maskmap,2).NE.ndivy ) &
+               call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout.' )
+          mask(:,:) = maskmap(:,:)
+      end if
+!number of unmask domains in layout must equal number of PEs assigned
+      n = count(mask)
+      if( n.NE.size(pes) )then
+          write( text,'(i8)' )n
+          call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for this layout and maskmap. Use ' &
+               //text//' PEs for this domain decomposition.' )
+      end if
+
+!place on PE array; need flag to assign them to j first and then i
+      allocate( pearray(0:ndivx-1,0:ndivy-1) )
+      pearray(:,:) = NULL_PE
+      ipos = NULL_PE; jpos = NULL_PE; pos = NULL_PE
+      n = 0
+      do j = 0,ndivy-1
+         do i = 0,ndivx-1
+            if( mask(i,j) )then
+                pearray(i,j) = pes(n)
+                if( pes(n).EQ.pe )then
+                    pos = n
+                    ipos = i
+                    jpos = j
+                end if
+                n = n + 1
+            end if
+         end do
+      end do
+      if( ipos.EQ.NULL_PE .OR. jpos.EQ.NULL_PE .or. pos.EQ.NULL_PE ) &
+           call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: pelist must include this PE.' )
+      if( debug )write( stderr(), * )'pe, ipos, jpos=', pe, ipos, jpos, ' pearray(:,jpos)=', pearray(:,jpos), &
+                                                                        ' pearray(ipos,:)=', pearray(ipos,:)
+      
+      if(blocks) then
+!do domain decomposition using 1D versions in X and Y
+      call mpp_define_domains( global_indices(1:2), ndivx, domain%x, &
+           pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos),offset=offsetx )
+      call mpp_define_domains( global_indices(3:4), ndivy, domain%y, &
+           pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:),offset=offsety )
+      else
+!do domain decomposition using 1D versions in X and Y
+      call mpp_define_domains( global_indices(1:2), ndivx, domain%x, &
+           pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos))
+      call mpp_define_domains( global_indices(3:4), ndivy, domain%y, &
+           pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:))
+      endif
+      if( domain%x%list(domain%x%pos)%pe.NE.domain%y%list(domain%y%pos)%pe ) &
+           call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pe.NE.domain%y%list(jpos)%pe.' ) 
+      domain%pos = pos
+      domain%pe  = pe
+
+!set up fold
+      domain%fold = 0
+      if( PRESENT(xflags) )then
+          if( BTEST(xflags,WEST) )domain%fold = domain%fold + FOLD_WEST_EDGE
+          if( BTEST(xflags,EAST) )domain%fold = domain%fold + FOLD_EAST_EDGE
+      end if
+      if( PRESENT(yflags) )then
+          if( BTEST(yflags,SOUTH) )domain%fold = domain%fold + FOLD_SOUTH_EDGE
+          if( BTEST(yflags,NORTH) )domain%fold = domain%fold + FOLD_NORTH_EDGE
+      end if
+          
+      if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,NORTH) )then
+          if( domain%y%cyclic )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic.' )
+          if( modulo(domain%x%global%size,2).NE.0 ) &
+               call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in X must be even when there is a fold in Y.' )
+!check if folded domain boundaries line up in X: compute domains lining up is a sufficient condition for symmetry
+          n = ndivx - 1
+          do i = 0,n/2
+             if( domain%x%list(i)%compute%size.NE.domain%x%list(n-i)%compute%size ) &
+                  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must line up (mirror-symmetric extents).' )
+          end do
+      end if
+      if( BTEST(domain%fold,WEST) .OR. BTEST(domain%fold,EAST) )then
+          if( domain%x%cyclic )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic.' )
+          if( modulo(domain%y%global%size,2).NE.0 ) &
+               call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in Y must be even when there is a fold in X.' )
+!check if folded domain boundaries line up in Y: compute domains lining up is a sufficient condition for symmetry
+          n = ndivy - 1
+          do i = 0,n/2
+             if( domain%y%list(i)%compute%size.NE.domain%y%list(n-i)%compute%size ) &
+                  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must line up (mirror-symmetric extents).' )
+          end do
+      end if
+
+!set up domain%list
+      if( debug )write( stderr(),'(a,9i4)' )'pe, domain=', pe, domain_info_buf(1:8)
+      if( pe.EQ.mpp_root_pe() .AND. PRESENT(name) )then
+          write( stdlog(), '(/a,i3,a,i3)' )trim(name)//' domain decomposition: ', ndivx, ' X', ndivy
+          write( stdlog(), '(3x,a)' )'pe,   is,  ie,  js,  je,    isd, ied, jsd, jed'
+      end if
+      call mpp_sync()
+      call mpp_get_compute_domain( domain, domain_info_buf(1), domain_info_buf(2), domain_info_buf(3), domain_info_buf(4) )
+      call mpp_get_data_domain   ( domain, domain_info_buf(5), domain_info_buf(6), domain_info_buf(7), domain_info_buf(8) )
+      n = size(pes)
+      allocate( domain%list(0:n-1) ) !this is only used for storage of remote compute and data domain info
+      do i = 0,n-1
+         m = mod(pos+i,n)
+         domain%list(m)%pe = pes(m)
+         call mpp_transmit( domain_info_buf(1:8), 8, pes(mod(pos+n-i,n)), domain_info_buf(9:16), 8, pes(m) )
+         domain%list(m)%x%compute%begin = domain_info_buf(9)
+         domain%list(m)%x%compute%end   = domain_info_buf(10)
+         domain%list(m)%y%compute%begin = domain_info_buf(11)
+         domain%list(m)%y%compute%end   = domain_info_buf(12)
+         domain%list(m)%x%data%begin = domain_info_buf(13)
+         domain%list(m)%x%data%end   = domain_info_buf(14)
+         domain%list(m)%y%data%begin = domain_info_buf(15)
+         domain%list(m)%y%data%end   = domain_info_buf(16)
+         if( pe.EQ.mpp_root_pe() .AND. PRESENT(name) )write( stdlog(), '(2x,i3,x,4i5,3x,4i5)' )pes(m), domain_info_buf(9:)
+      end do
+      call mpp_sync_self(pes)
+      domain%list(:)%x%compute%size = domain%list(:)%x%compute%end - domain%list(:)%x%compute%begin + 1
+      domain%list(:)%y%compute%size = domain%list(:)%y%compute%end - domain%list(:)%y%compute%begin + 1
+      domain%list(:)%x%data%size = domain%list(:)%x%data%end - domain%list(:)%x%data%begin + 1
+      domain%list(:)%y%data%size = domain%list(:)%y%data%end - domain%list(:)%y%data%begin + 1
+
+      domain%remote_domains_initialized = .FALSE.
+      domain%remote_off_domains_initialized = .FALSE.
+      call compute_overlaps(domain)
+!PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
+      deallocate( pes, mask, pearray )
+          
+      return
+    end subroutine mpp_define_domains2D
+
+    subroutine mpp_broadcast_domain( domain )
+!broadcast domain (useful only outside the context of its own pelist)
+      type(domain2D), intent(inout) :: domain
+      integer, allocatable :: pes(:)
+      logical :: native         !true if I'm on the pelist of this domain
+      integer :: listsize, listpos
+      integer :: n
+      integer, dimension(5) :: msg, info         !pe and compute domain of each item in list
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN: You must first call mpp_domains_init.' )
+
+!get the current pelist
+      allocate( pes(0:mpp_npes()-1) )
+      call mpp_get_current_pelist(pes)
+
+!am I part of this domain?
+      native = ASSOCIATED(domain%list)
+
+!set local list size
+      if( native )then
+          listsize = size(domain%list)
+      else
+          listsize = 0
+      end if
+      call mpp_max(listsize)
+
+      if( .NOT.native )then
+!initialize domain%list and set null values in message
+          allocate( domain%list(0:listsize-1) )
+          domain%pe = NULL_PE
+          domain%pos = -1
+          domain%x%compute%begin =  HUGE(1)
+          domain%x%compute%end   = -HUGE(1)
+          domain%y%compute%begin =  HUGE(1)
+          domain%y%compute%end   = -HUGE(1)
+      end if
+!initialize values in info
+      info(1) = domain%pe
+      call mpp_get_compute_domain( domain, info(2), info(3), info(4), info(5) )
+
+!broadcast your info across current pelist and unpack if needed
+      listpos = 0
+      do n = 0,mpp_npes()-1
+         msg = info
+         if( pe.EQ.pes(n) .AND. debug )write( stderr(),* )'PE ', pe, 'broadcasting msg ', msg
+         call mpp_broadcast( msg, 5, pes(n) )
+!no need to unpack message if native
+!no need to unpack message from non-native PE
+         if( .NOT.native .AND. msg(1).NE.NULL_PE )then
+             domain%list(listpos)%pe = msg(1)
+             domain%list(listpos)%x%compute%begin = msg(2)
+             domain%list(listpos)%x%compute%end   = msg(3)
+             domain%list(listpos)%y%compute%begin = msg(4)
+             domain%list(listpos)%y%compute%end   = msg(5)
+             listpos = listpos + 1
+             if( debug )write( stderr(),* )'PE ', pe, 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
+         end if
+      end do
+    end subroutine mpp_broadcast_domain
+
+    subroutine compute_overlaps( domain )
+!computes remote domain overlaps
+!assumes only one in each direction
+      type(domain2D), intent(inout) :: domain
+      integer :: i, j, k, m, n
+      integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed, isg, ieg, jsg, jeg, ioff, joff
+      integer :: list
+
+      if( grid_offset_type.EQ.AGRID .AND. domain%remote_domains_initialized     )return
+      if( grid_offset_type.NE.AGRID .AND. domain%remote_off_domains_initialized )return
+      domain%gridtype = grid_offset_type
+      n = size(domain%list)
+!send
+      call mpp_get_compute_domain( domain, isc, iec, jsc, jec )
+      call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ioff, ysize=joff ) !cyclic offsets
+      domain%list(:)%overlap = .FALSE.
+      do list = 0,n-1
+         m = mod( domain%pos+list, n )
+!to_pe's eastern halo
+         is = domain%list(m)%x%compute%end+1; ie = domain%list(m)%x%data%end
+         js = domain%list(m)%y%compute%begin; je = domain%list(m)%y%compute%end
+         if( is.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,EAST) )then
+                     is = is - 1; ie = ie - 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_w_off%overlap = .TRUE.
+                 domain%list(m)%send_w_off%is = is
+                 domain%list(m)%send_w_off%ie = ie
+                 domain%list(m)%send_w_off%js = js
+                 domain%list(m)%send_w_off%je = je
+             else
+                 domain%list(m)%send_w%overlap = .TRUE.
+                 domain%list(m)%send_w%is = is
+                 domain%list(m)%send_w%ie = ie
+                 domain%list(m)%send_w%js = js
+                 domain%list(m)%send_w%je = je
+             end if
+         else
+             domain%list(m)%send_w%overlap = .FALSE.
+             domain%list(m)%send_w_off%overlap = .FALSE.
+         end if
+!to_pe's SE halo
+         is = domain%list(m)%x%compute%end+1; ie = domain%list(m)%x%data%end
+         js = domain%list(m)%y%data%begin; je = domain%list(m)%y%compute%begin-1
+         if( is.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,EAST) )then
+                     is = is - 1; ie = ie - 1
+                 end if
+             end if
+         end if
+         if( jsg.GT.je )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_nw_off%overlap = .TRUE.
+                 domain%list(m)%send_nw_off%is = is
+                 domain%list(m)%send_nw_off%ie = ie
+                 domain%list(m)%send_nw_off%js = js
+                 domain%list(m)%send_nw_off%je = je
+             else
+                 domain%list(m)%send_nw%overlap = .TRUE.
+                 domain%list(m)%send_nw%is = is
+                 domain%list(m)%send_nw%ie = ie
+                 domain%list(m)%send_nw%js = js
+                 domain%list(m)%send_nw%je = je
+             end if
+         else
+             domain%list(m)%send_nw%overlap = .FALSE.
+             domain%list(m)%send_nw_off%overlap = .FALSE.
+         end if
+!to_pe's southern halo
+         is = domain%list(m)%x%compute%begin; ie = domain%list(m)%x%compute%end
+         js = domain%list(m)%y%data%begin; je = domain%list(m)%y%compute%begin-1
+         if( jsg.GT.je )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_n_off%overlap = .TRUE.
+                 domain%list(m)%send_n_off%is = is
+                 domain%list(m)%send_n_off%ie = ie
+                 domain%list(m)%send_n_off%js = js
+                 domain%list(m)%send_n_off%je = je
+             else
+                 domain%list(m)%send_n%overlap = .TRUE.
+                 domain%list(m)%send_n%is = is
+                 domain%list(m)%send_n%ie = ie
+                 domain%list(m)%send_n%js = js
+                 domain%list(m)%send_n%je = je
+             end if
+         else
+             domain%list(m)%send_n%overlap = .FALSE.
+             domain%list(m)%send_n_off%overlap = .FALSE.
+         end if
+!to_pe's SW halo
+         is = domain%list(m)%x%data%begin; ie = domain%list(m)%x%compute%begin-1
+         js = domain%list(m)%y%data%begin; je = domain%list(m)%y%compute%begin-1
+         if( isg.GT.ie )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         if( jsg.GT.je )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_ne_off%overlap = .TRUE.
+                 domain%list(m)%send_ne_off%is = is
+                 domain%list(m)%send_ne_off%ie = ie
+                 domain%list(m)%send_ne_off%js = js
+                 domain%list(m)%send_ne_off%je = je
+             else
+                 domain%list(m)%send_ne%overlap = .TRUE.
+                 domain%list(m)%send_ne%is = is
+                 domain%list(m)%send_ne%ie = ie
+                 domain%list(m)%send_ne%js = js
+                 domain%list(m)%send_ne%je = je
+             end if
+         else
+             domain%list(m)%send_ne%overlap = .FALSE.
+             domain%list(m)%send_ne_off%overlap = .FALSE.
+         end if
+!to_pe's western halo
+         is = domain%list(m)%x%data%begin; ie = domain%list(m)%x%compute%begin-1
+         js = domain%list(m)%y%compute%begin; je = domain%list(m)%y%compute%end
+         if( isg.GT.ie )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_e_off%overlap = .TRUE.
+                 domain%list(m)%send_e_off%is = is
+                 domain%list(m)%send_e_off%ie = ie
+                 domain%list(m)%send_e_off%js = js
+                 domain%list(m)%send_e_off%je = je
+             else
+                 domain%list(m)%send_e%overlap = .TRUE.
+                 domain%list(m)%send_e%is = is
+                 domain%list(m)%send_e%ie = ie
+                 domain%list(m)%send_e%js = js
+                 domain%list(m)%send_e%je = je
+             end if
+         else
+             domain%list(m)%send_e%overlap = .FALSE.
+             domain%list(m)%send_e_off%overlap = .FALSE.
+         end if
+!to_pe's NW halo
+         is = domain%list(m)%x%data%begin; ie = domain%list(m)%x%compute%begin-1
+         js = domain%list(m)%y%compute%end+1; je = domain%list(m)%y%data%end
+         if( isg.GT.ie )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         if( js.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_se_off%overlap = .TRUE.
+                 domain%list(m)%send_se_off%is = is
+                 domain%list(m)%send_se_off%ie = ie
+                 domain%list(m)%send_se_off%js = js
+                 domain%list(m)%send_se_off%je = je
+             else
+                 domain%list(m)%send_se%overlap = .TRUE.
+                 domain%list(m)%send_se%is = is
+                 domain%list(m)%send_se%ie = ie
+                 domain%list(m)%send_se%js = js
+                 domain%list(m)%send_se%je = je
+             end if
+         else
+             domain%list(m)%send_se%overlap = .FALSE.
+             domain%list(m)%send_se_off%overlap = .FALSE.
+         end if
+!to_pe's northern halo
+         is = domain%list(m)%x%compute%begin; ie = domain%list(m)%x%compute%end
+         js = domain%list(m)%y%compute%end+1; je = domain%list(m)%y%data%end
+         if( js.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_s_off%overlap = .TRUE.
+                 domain%list(m)%send_s_off%is = is
+                 domain%list(m)%send_s_off%ie = ie
+                 domain%list(m)%send_s_off%js = js
+                 domain%list(m)%send_s_off%je = je
+             else
+                 domain%list(m)%send_s%overlap = .TRUE.
+                 domain%list(m)%send_s%is = is
+                 domain%list(m)%send_s%ie = ie
+                 domain%list(m)%send_s%js = js
+                 domain%list(m)%send_s%je = je
+             end if
+         else
+             domain%list(m)%send_s%overlap = .FALSE.
+             domain%list(m)%send_s_off%overlap = .FALSE.
+         end if
+!to_pe's NE halo
+         is = domain%list(m)%x%compute%end+1; ie = domain%list(m)%x%data%end
+         js = domain%list(m)%y%compute%end+1; je = domain%list(m)%y%data%end
+         if( is.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+             end if
+         end if
+         if( js.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         is = max(is,isc); ie = min(ie,iec)
+         js = max(js,jsc); je = min(je,jec)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%send_sw_off%overlap = .TRUE.
+                 domain%list(m)%send_sw_off%is = is
+                 domain%list(m)%send_sw_off%ie = ie
+                 domain%list(m)%send_sw_off%js = js
+                 domain%list(m)%send_sw_off%je = je
+             else
+                 domain%list(m)%send_sw%overlap = .TRUE.
+                 domain%list(m)%send_sw%is = is
+                 domain%list(m)%send_sw%ie = ie
+                 domain%list(m)%send_sw%js = js
+                 domain%list(m)%send_sw%je = je
+             end if
+         else
+             domain%list(m)%send_sw%overlap = .FALSE.
+             domain%list(m)%send_sw_off%overlap = .FALSE.
+         end if
+      end do
+             
+!recv
+      do list = 0,n-1
+         m = mod( domain%pos+n-list, n )
+         call mpp_get_compute_domain( domain%list(m), isc, iec, jsc, jec )
+!recv_e
+         isd = domain%x%compute%end+1; ied = domain%x%data%end
+         jsd = domain%y%compute%begin; jed = domain%y%compute%end
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_e%folded = .FALSE.
+         if( isd.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 domain%list(m)%recv_e%folded = .TRUE.
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 if( BTEST(grid_offset_type,EAST) )then
+                     is = is - 1; ie = ie - 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_e_off%overlap = .TRUE.
+                 domain%list(m)%recv_e_off%is = is
+                 domain%list(m)%recv_e_off%ie = ie
+                 domain%list(m)%recv_e_off%js = js
+                 domain%list(m)%recv_e_off%je = je
+             else
+                 domain%list(m)%recv_e%overlap = .TRUE.
+                 domain%list(m)%recv_e%is = is
+                 domain%list(m)%recv_e%ie = ie
+                 domain%list(m)%recv_e%js = js
+                 domain%list(m)%recv_e%je = je
+             endif
+         else
+             domain%list(m)%recv_e%overlap = .FALSE.
+             domain%list(m)%recv_e_off%overlap = .FALSE.
+         end if
+!recv_se
+         isd = domain%x%compute%end+1; ied = domain%x%data%end
+         jsd = domain%y%data%begin; jed = domain%y%compute%begin-1
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_se%folded = .FALSE.
+         if( jed.LT.jsg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 domain%list(m)%recv_se%folded = .TRUE.
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         if( isd.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 domain%list(m)%recv_se%folded = .TRUE.
+                 if( BTEST(grid_offset_type,EAST) )then
+                     is = is - 1; ie = ie - 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_se_off%overlap = .TRUE.
+                 domain%list(m)%recv_se_off%is = is
+                 domain%list(m)%recv_se_off%ie = ie
+                 domain%list(m)%recv_se_off%js = js
+                 domain%list(m)%recv_se_off%je = je
+             else
+                 domain%list(m)%recv_se%overlap = .TRUE.
+                 domain%list(m)%recv_se%is = is
+                 domain%list(m)%recv_se%ie = ie
+                 domain%list(m)%recv_se%js = js
+                 domain%list(m)%recv_se%je = je
+             endif
+         else
+             domain%list(m)%recv_se%overlap = .FALSE.
+             domain%list(m)%recv_se_off%overlap = .FALSE.
+         end if
+!recv_s
+         isd = domain%x%compute%begin; ied = domain%x%compute%end
+         jsd = domain%y%data%begin; jed = domain%y%compute%begin-1
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_s%folded = .FALSE.
+         if( jed.LT.jsg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 domain%list(m)%recv_s%folded = .TRUE.
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_s_off%overlap = .TRUE.
+                 domain%list(m)%recv_s_off%is = is
+                 domain%list(m)%recv_s_off%ie = ie
+                 domain%list(m)%recv_s_off%js = js
+                 domain%list(m)%recv_s_off%je = je
+             else
+                 domain%list(m)%recv_s%overlap = .TRUE.
+                 domain%list(m)%recv_s%is = is
+                 domain%list(m)%recv_s%ie = ie
+                 domain%list(m)%recv_s%js = js
+                 domain%list(m)%recv_s%je = je
+             endif
+         else
+             domain%list(m)%recv_s%overlap = .FALSE.
+             domain%list(m)%recv_s_off%overlap = .FALSE.
+
+         end if
+!recv_sw
+         isd = domain%x%data%begin; ied = domain%x%compute%begin-1
+         jsd = domain%y%data%begin; jed = domain%y%compute%begin-1
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_sw%folded = .FALSE.
+         if( jed.LT.jsg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js-joff; je = je-joff
+             else if( BTEST(domain%fold,SOUTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
+                 domain%list(m)%recv_sw%folded = .TRUE.
+                 if( BTEST(grid_offset_type,SOUTH) )then
+                     js = js + 1; je = je + 1
+                 end if
+             end if
+         end if
+         if( ied.LT.isg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 domain%list(m)%recv_sw%folded = .TRUE.
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_sw_off%overlap = .TRUE.
+                 domain%list(m)%recv_sw_off%is = is
+                 domain%list(m)%recv_sw_off%ie = ie
+                 domain%list(m)%recv_sw_off%js = js
+                 domain%list(m)%recv_sw_off%je = je
+             else
+                 domain%list(m)%recv_sw%overlap = .TRUE.
+                 domain%list(m)%recv_sw%is = is
+                 domain%list(m)%recv_sw%ie = ie
+                 domain%list(m)%recv_sw%js = js
+                 domain%list(m)%recv_sw%je = je
+             endif
+         else
+             domain%list(m)%recv_sw%overlap = .FALSE.
+             domain%list(m)%recv_sw_off%overlap = .FALSE.
+         end if
+!recv_w
+         isd = domain%x%data%begin; ied = domain%x%compute%begin-1
+         jsd = domain%y%compute%begin; jed = domain%y%compute%end
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_w%folded = .FALSE.
+         if( ied.LT.isg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 domain%list(m)%recv_w%folded = .TRUE.
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_w_off%overlap = .TRUE.
+                 domain%list(m)%recv_w_off%is = is
+                 domain%list(m)%recv_w_off%ie = ie
+                 domain%list(m)%recv_w_off%js = js
+                 domain%list(m)%recv_w_off%je = je
+             else
+                 domain%list(m)%recv_w%overlap = .TRUE.
+                 domain%list(m)%recv_w%is = is
+                 domain%list(m)%recv_w%ie = ie
+                 domain%list(m)%recv_w%js = js
+                 domain%list(m)%recv_w%je = je
+             endif
+         else
+             domain%list(m)%recv_w%overlap = .FALSE.
+             domain%list(m)%recv_w_off%overlap = .FALSE.
+         end if
+!recv_nw
+         isd = domain%x%data%begin; ied = domain%x%compute%begin-1
+         jsd = domain%y%compute%end+1; jed = domain%y%data%end
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_nw%folded = .FALSE.
+         if( jsd.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 domain%list(m)%recv_nw%folded = .TRUE.
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         if( ied.LT.isg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is-ioff; ie = ie-ioff
+             else if( BTEST(domain%fold,WEST) )then
+                 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 domain%list(m)%recv_nw%folded = .TRUE.
+                 if( BTEST(grid_offset_type,WEST) )then
+                     is = is + 1; ie = ie + 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_nw_off%overlap = .TRUE.
+                 domain%list(m)%recv_nw_off%is = is
+                 domain%list(m)%recv_nw_off%ie = ie
+                 domain%list(m)%recv_nw_off%js = js
+                 domain%list(m)%recv_nw_off%je = je
+             else
+                 domain%list(m)%recv_nw%overlap = .TRUE.
+                 domain%list(m)%recv_nw%is = is
+                 domain%list(m)%recv_nw%ie = ie
+                 domain%list(m)%recv_nw%js = js
+                 domain%list(m)%recv_nw%je = je
+             endif
+         else
+             domain%list(m)%recv_nw%overlap = .FALSE.
+             domain%list(m)%recv_nw_off%overlap = .FALSE.
+         end if
+!recv_n
+         isd = domain%x%compute%begin; ied = domain%x%compute%end
+         jsd = domain%y%compute%end+1; jed = domain%y%data%end
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_n%folded = .FALSE.
+         if( jsd.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 domain%list(m)%recv_n%folded = .TRUE.
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_n_off%overlap = .TRUE.
+                 domain%list(m)%recv_n_off%is = is
+                 domain%list(m)%recv_n_off%ie = ie
+                 domain%list(m)%recv_n_off%js = js
+                 domain%list(m)%recv_n_off%je = je
+             else
+                 domain%list(m)%recv_n%overlap = .TRUE.
+                 domain%list(m)%recv_n%is = is
+                 domain%list(m)%recv_n%ie = ie
+                 domain%list(m)%recv_n%js = js
+                 domain%list(m)%recv_n%je = je
+             end if
+         else
+             domain%list(m)%recv_n%overlap = .FALSE.
+             domain%list(m)%recv_n_off%overlap = .FALSE.
+         end if
+!recv_ne
+         isd = domain%x%compute%end+1; ied = domain%x%data%end
+         jsd = domain%y%compute%end+1; jed = domain%y%data%end
+         is=isc; ie=iec; js=jsc; je=jec
+         domain%list(m)%recv_ne%folded = .FALSE.
+         if( jsd.GT.jeg )then
+             if( domain%y%cyclic )then !try cyclic offset
+                 js = js+joff; je = je+joff
+             else if( BTEST(domain%fold,NORTH) )then
+                 i=is; is = isg+ieg-ie; ie = isg+ieg-i
+                 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
+                 domain%list(m)%recv_ne%folded = .TRUE.
+                 if( BTEST(grid_offset_type,NORTH) )then
+                     js = js - 1; je = je - 1
+                 end if
+             end if
+         end if
+         if( isd.GT.ieg )then
+             if( domain%x%cyclic )then !try cyclic offset
+                 is = is+ioff; ie = ie+ioff
+             else if( BTEST(domain%fold,EAST) )then
+                 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
+                 j=js; js = jsg+jeg-je; je = jsg+jeg-j
+                 domain%list(m)%recv_ne%folded = .TRUE.
+                 if( BTEST(grid_offset_type,EAST) )then
+                     is = is - 1; ie = ie - 1
+                 end if
+             end if
+         end if
+         is = max(isd,is); ie = min(ied,ie)
+         js = max(jsd,js); je = min(jed,je)
+         if( ie.GE.is .AND. je.GE.js )then
+             domain%list(m)%overlap = .TRUE.
+             if( grid_offset_type.NE.AGRID )then
+                 domain%list(m)%recv_ne_off%overlap = .TRUE.
+                 domain%list(m)%recv_ne_off%is = is
+                 domain%list(m)%recv_ne_off%ie = ie
+                 domain%list(m)%recv_ne_off%js = js
+                 domain%list(m)%recv_ne_off%je = je
+             else
+                 domain%list(m)%recv_ne%overlap = .TRUE.
+                 domain%list(m)%recv_ne%is = is
+                 domain%list(m)%recv_ne%ie = ie
+                 domain%list(m)%recv_ne%js = js
+                 domain%list(m)%recv_ne%je = je
+             end if
+         else
+             domain%list(m)%recv_ne%overlap = .FALSE.
+             domain%list(m)%recv_ne_off%overlap = .FALSE.
+         end if
+      end do
+      if( grid_offset_type.EQ.AGRID )domain%remote_domains_initialized = .TRUE.
+      if( grid_offset_type.NE.AGRID )domain%remote_off_domains_initialized = .TRUE.
+      return
+    end subroutine compute_overlaps
+
+    subroutine mpp_define_layout2D( global_indices, ndivs, layout )
+      integer, intent(in) :: global_indices(4) !(/ isg, ieg, jsg, jeg /)
+      integer, intent(in) :: ndivs !number of divisions to divide global domain
+      integer, intent(out) :: layout(2)
+
+      integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
+
+      isg = global_indices(1)
+      ieg = global_indices(2)
+      jsg = global_indices(3)
+      jeg = global_indices(4)
+
+      isz = ieg - isg + 1
+      jsz = jeg - jsg + 1
+!first try to divide ndivs in the domain aspect ratio: if imperfect aspect, reduce idiv till it divides ndivs
+      idiv = nint( sqrt(float(ndivs*isz)/jsz) )
+      idiv = max(idiv,1) !for isz=1 line above can give 0
+      do while( mod(ndivs,idiv).NE.0 )
+         idiv = idiv - 1
+      end do                 !will terminate at idiv=1 if not before
+      jdiv = ndivs/idiv
+
+      layout = (/ idiv, jdiv /)
+      return
+    end subroutine mpp_define_layout2D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!     MPP_GET and SET routiness: retrieve various components of domains       !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_get_compute_domain1D( domain, begin, end, size, max_size, is_global )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out), optional :: begin, end, size, max_size
+      logical, intent(out), optional :: is_global
+
+      if( PRESENT(begin)     )begin     = domain%compute%begin
+      if( PRESENT(end)       )end       = domain%compute%end
+      if( PRESENT(size)      )size      = domain%compute%size
+      if( PRESENT(max_size)  )max_size  = domain%compute%max_size
+      if( PRESENT(is_global) )is_global = domain%compute%is_global
+      return
+    end subroutine mpp_get_compute_domain1D
+
+    subroutine mpp_get_data_domain1D( domain, begin, end, size, max_size, is_global )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out), optional :: begin, end, size, max_size
+      logical, intent(out), optional :: is_global
+
+      if( PRESENT(begin)     )begin     = domain%data%begin
+      if( PRESENT(end)       )end       = domain%data%end
+      if( PRESENT(size)      )size      = domain%data%size
+      if( PRESENT(max_size)  )max_size  = domain%data%max_size
+      if( PRESENT(is_global) )is_global = domain%data%is_global
+      return
+    end subroutine mpp_get_data_domain1D
+
+    subroutine mpp_get_global_domain1D( domain, begin, end, size, max_size )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out), optional :: begin, end, size, max_size
+
+      if( PRESENT(begin)    )begin    = domain%global%begin
+      if( PRESENT(end)      )end      = domain%global%end
+      if( PRESENT(size)     )size     = domain%global%size
+      if( PRESENT(max_size) )max_size = domain%global%max_size
+      return
+    end subroutine mpp_get_global_domain1D
+
+    subroutine mpp_get_compute_domain2D( domain, xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size, &
+         x_is_global, y_is_global )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out), optional :: xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size
+      logical, intent(out), optional :: x_is_global, y_is_global
+      call mpp_get_compute_domain( domain%x, xbegin, xend, xsize, xmax_size, x_is_global )
+      call mpp_get_compute_domain( domain%y, ybegin, yend, ysize, ymax_size, y_is_global )
+      return
+    end subroutine mpp_get_compute_domain2D
+
+    subroutine mpp_get_data_domain2D( domain, xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size, &
+         x_is_global, y_is_global )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out), optional :: xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size
+      logical, intent(out), optional :: x_is_global, y_is_global
+      call mpp_get_data_domain( domain%x, xbegin, xend, xsize, xmax_size, x_is_global )
+      call mpp_get_data_domain( domain%y, ybegin, yend, ysize, ymax_size, y_is_global )
+      return
+    end subroutine mpp_get_data_domain2D
+
+    subroutine mpp_get_global_domain2D( domain, xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out), optional :: xbegin, xend, ybegin, yend, xsize, xmax_size, ysize, ymax_size
+      call mpp_get_global_domain( domain%x, xbegin, xend, xsize, xmax_size )
+      call mpp_get_global_domain( domain%y, ybegin, yend, ysize, ymax_size )
+      return
+    end subroutine mpp_get_global_domain2D
+
+    subroutine mpp_get_domain_components( domain, x, y )
+      type(domain2D), intent(in) :: domain
+      type(domain1D), intent(out), optional :: x, y
+      if( PRESENT(x) )x = domain%x
+      if( PRESENT(y) )y = domain%y
+      return
+    end subroutine mpp_get_domain_components
+
+    subroutine mpp_get_compute_domains1D( domain, begin, end, size )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out), optional, dimension(:) :: begin, end, size 
+
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: must first call mpp_domains_init.' )
+!we use shape instead of size for error checks because size is used as an argument
+      if( PRESENT(begin) )then
+          if( any(shape(begin).NE.shape(domain%list)) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: begin array size does not match domain.' )
+          begin(:) = domain%list(:)%compute%begin
+      end if
+      if( PRESENT(end) )then
+          if( any(shape(end).NE.shape(domain%list)) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: end array size does not match domain.' )
+          end(:) = domain%list(:)%compute%end
+      end if
+      if( PRESENT(size) )then
+          if( any(shape(size).NE.shape(domain%list)) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: size array size does not match domain.' )
+          size(:) = domain%list(:)%compute%size
+      end if
+      return
+    end subroutine mpp_get_compute_domains1D
+
+    subroutine mpp_get_compute_domains2D( domain, xbegin, xend, xsize, ybegin, yend, ysize )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out), optional, dimension(:) :: xbegin, xend, xsize, ybegin, yend, ysize
+
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: must first call mpp_domains_init.' )
+
+      if( PRESENT(xbegin) )then
+          if( size(xbegin).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: xbegin array size does not match domain.' )
+          xbegin(:) = domain%list(:)%x%compute%begin
+      end if
+      if( PRESENT(xend) )then
+          if( size(xend).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: xend array size does not match domain.' )
+          xend(:) = domain%list(:)%x%compute%end
+      end if
+      if( PRESENT(xsize) )then
+          if( size(xsize).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: xsize array size does not match domain.' )
+          xsize(:) = domain%list(:)%x%compute%size
+      end if
+      if( PRESENT(ybegin) )then
+          if( size(ybegin).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: ybegin array size does not match domain.' )
+          ybegin(:) = domain%list(:)%y%compute%begin
+      end if
+      if( PRESENT(yend) )then
+          if( size(yend).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: yend array size does not match domain.' )
+          yend(:) = domain%list(:)%y%compute%end
+      end if
+      if( PRESENT(ysize) )then
+          if( size(ysize).NE.size(domain%list) ) &
+               call mpp_error( FATAL, 'MPP_GET_COMPUTE_DOMAINS: ysize array size does not match domain.' )
+          ysize(:) = domain%list(:)%y%compute%size
+      end if
+      return
+    end subroutine mpp_get_compute_domains2D
+
+    subroutine mpp_get_pelist1D( domain, pelist, pos )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out) :: pelist(:)
+      integer, intent(out), optional :: pos
+      integer :: ndivs
+
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_PELIST: must first call mpp_domains_init.' )
+      ndivs = size(domain%list)
+      
+      if( size(pelist).NE.ndivs ) &
+           call mpp_error( FATAL, 'MPP_GET_PELIST: pelist array size does not match domain.' )
+
+      pelist(:) = domain%list(0:ndivs-1)%pe
+      if( PRESENT(pos) )pos = domain%pos
+      return
+    end subroutine mpp_get_pelist1D
+
+    subroutine mpp_get_pelist2D( domain, pelist, pos )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out) :: pelist(:)
+      integer, intent(out), optional :: pos
+
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_PELIST: must first call mpp_domains_init.' )
+      if( size(pelist).NE.size(domain%list) ) &
+           call mpp_error( FATAL, 'MPP_GET_PELIST: pelist array size does not match domain.' )
+
+      pelist(:) = domain%list(:)%pe
+      if( PRESENT(pos) )pos = domain%pos
+      return
+    end subroutine mpp_get_pelist2D
+
+    subroutine mpp_get_layout1D( domain, layout )
+      type(domain1D), intent(in) :: domain
+      integer, intent(out) :: layout
+      
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_LAYOUT: must first call mpp_domains_init.' )
+
+      layout = size(domain%list)
+      return
+    end subroutine mpp_get_layout1D
+
+    subroutine mpp_get_layout2D( domain, layout )
+      type(domain2D), intent(in) :: domain
+      integer, intent(out) :: layout(2)
+      
+      if( .NOT.module_is_initialized ) &
+           call mpp_error( FATAL, 'MPP_GET_LAYOUT: must first call mpp_domains_init.' )
+
+      layout(1) = size(domain%x%list)
+      layout(2) = size(domain%y%list)
+      return
+    end subroutine mpp_get_layout2D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!              MPP_UPDATE_DOMAINS: fill halos for 2D decomposition            !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define VECTOR_FIELD_
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r8_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r8_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r8_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r8_5D
+
+#ifdef  VECTOR_FIELD_
+#define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r8_2Dv
+#define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r8_3Dv
+#define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r8_4Dv
+#define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r8_5Dv
+#endif
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r8_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r8_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r8_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r8_5D
+#include <mpp_update_domains2D.h>
+#undef  VECTOR_FIELD_
+
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c8_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c8_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c8_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c8_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c8_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c8_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c8_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c8_5D
+#include <mpp_update_domains2D.h>
+
+#ifndef no_8byte_integers
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i8_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i8_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i8_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i8_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i8_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i8_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i8_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i8_5D
+#include <mpp_update_domains2D.h>
+
+#define MPP_TYPE_ logical(LONG_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_l8_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_l8_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_l8_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_l8_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_l8_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_l8_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_l8_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_l8_5D
+#include <mpp_update_domains2D.h>
+#endif
+
+#ifndef no_4byte_reals
+#define VECTOR_FIELD_
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r4_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r4_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r4_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r4_5D
+#ifdef  VECTOR_FIELD_
+#define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r4_2Dv
+#define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r4_3Dv
+#define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r4_4Dv
+#define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r4_5Dv
+#endif
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r4_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r4_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r4_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r4_5D
+#include <mpp_update_domains2D.h>
+#undef  VECTOR_FIELD_
+#endif
+
+#ifndef no_4byte_cmplx
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c4_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c4_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c4_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c4_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c4_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c4_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c4_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c4_5D
+#include <mpp_update_domains2D.h>
+#endif
+
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i4_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i4_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i4_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i4_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i4_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i4_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i4_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i4_5D
+#include <mpp_update_domains2D.h>
+
+#define MPP_TYPE_ logical(INT_KIND)
+#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_l4_2D
+#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_l4_3D
+#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_l4_4D
+#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_l4_5D
+#define MPP_REDISTRIBUTE_2D_ mpp_redistribute_l4_2D
+#define MPP_REDISTRIBUTE_3D_ mpp_redistribute_l4_3D
+#define MPP_REDISTRIBUTE_4D_ mpp_redistribute_l4_4D
+#define MPP_REDISTRIBUTE_5D_ mpp_redistribute_l4_5D
+#include <mpp_update_domains2D.h>
+
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_r8_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_r8_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_r8_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_r8_5D
+!#define MPP_TYPE_ real(DOUBLE_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_c8_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_c8_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_c8_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_c8_5D
+!#define MPP_TYPE_ complex(DOUBLE_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#ifndef no_8byte_integers
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_i8_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_i8_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_i8_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_i8_5D
+!#define MPP_TYPE_ integer(LONG_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_l8_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_l8_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_l8_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_l8_5D
+!#define MPP_TYPE_ logical(LONG_KIND)
+!#include <mpp_update_domains1D.h>
+!#endif
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_r4_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_r4_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_r4_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_r4_5D
+!#define MPP_TYPE_ real(FLOAT_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_c4_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_c4_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_c4_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_c4_5D
+!#define MPP_TYPE_ complex(FLOAT_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_i4_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_i4_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_i4_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_i4_5D
+!#define MPP_TYPE_ integer(INT_KIND)
+!#include <mpp_update_domains1D.h>
+!
+!#define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain1D_l4_2D
+!#define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain1D_l4_3D
+!#define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain1D_l4_4D
+!#define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain1D_l4_5D
+!#define MPP_TYPE_ logical(INT_KIND)
+!#include <mpp_update_domains1D.h>
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!              MPP_GLOBAL_REDUCE: get global max/min of field                 !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_max_r8_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_max_r8_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_max_r8_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_max_r8_5d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define REDUCE_VAL_ maxval
+#define REDUCE_LOC_ maxloc
+#define MPP_REDUCE_ mpp_max
+#include <mpp_global_reduce.h>
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_min_r8_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_min_r8_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_min_r8_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_min_r8_5d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define REDUCE_VAL_ minval
+#define REDUCE_LOC_ minloc
+#define MPP_REDUCE_ mpp_min
+#include <mpp_global_reduce.h>
+
+#ifndef no_4byte_reals
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_max_r4_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_max_r4_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_max_r4_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_max_r4_5d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define REDUCE_VAL_ maxval
+#define REDUCE_LOC_ maxloc
+#define MPP_REDUCE_ mpp_max
+#include <mpp_global_reduce.h>
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_min_r4_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_min_r4_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_min_r4_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_min_r4_5d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define REDUCE_VAL_ minval
+#define REDUCE_LOC_ minloc
+#define MPP_REDUCE_ mpp_min
+#include <mpp_global_reduce.h>
+#endif
+
+#ifndef no_8byte_integers
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_max_i8_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_max_i8_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_max_i8_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_max_i8_5d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define REDUCE_VAL_ maxval
+#define REDUCE_LOC_ maxloc
+#define MPP_REDUCE_ mpp_max
+#include <mpp_global_reduce.h>
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_min_i8_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_min_i8_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_min_i8_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_min_i8_5d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define REDUCE_VAL_ minval
+#define REDUCE_LOC_ minloc
+#define MPP_REDUCE_ mpp_min
+#include <mpp_global_reduce.h>
+#endif
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_max_i4_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_max_i4_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_max_i4_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_max_i4_5d
+#define MPP_TYPE_ integer(INT_KIND)
+#define REDUCE_VAL_ maxval
+#define REDUCE_LOC_ maxloc
+#define MPP_REDUCE_ mpp_max
+#include <mpp_global_reduce.h>
+
+#define MPP_GLOBAL_REDUCE_2D_ mpp_global_min_i4_2d
+#define MPP_GLOBAL_REDUCE_3D_ mpp_global_min_i4_3d
+#define MPP_GLOBAL_REDUCE_4D_ mpp_global_min_i4_4d
+#define MPP_GLOBAL_REDUCE_5D_ mpp_global_min_i4_5d
+#define MPP_TYPE_ integer(INT_KIND)
+#define REDUCE_VAL_ minval
+#define REDUCE_LOC_ minloc
+#define MPP_REDUCE_ mpp_min
+#include <mpp_global_reduce.h>
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                   MPP_GLOBAL_SUM: global sum of field                       !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r8_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r8_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r8_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r8_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#ifndef no_4byte_reals
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r4_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ real(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r4_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ real(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r4_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ real(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_r4_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ real(FLOAT_KIND)
+#include <mpp_global_sum.h>
+#endif
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c8_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c8_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c8_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c8_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#include <mpp_global_sum.h>
+
+#ifndef no_4byte_cmplx
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c4_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c4_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c4_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_c4_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#include <mpp_global_sum.h>
+#endif
+
+#ifndef no_8byte_integers
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i8_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ integer(LONG_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i8_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ integer(LONG_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i8_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ integer(LONG_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i8_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ integer(LONG_KIND)
+#include <mpp_global_sum.h>
+#endif
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i4_2d
+#define MPP_EXTRA_INDICES_
+#define MPP_TYPE_ integer(INT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i4_3d
+#define MPP_EXTRA_INDICES_ ,:
+#define MPP_TYPE_ integer(INT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i4_4d
+#define MPP_EXTRA_INDICES_ ,:,:
+#define MPP_TYPE_ integer(INT_KIND)
+#include <mpp_global_sum.h>
+
+#define MPP_GLOBAL_SUM_ mpp_global_sum_i4_5d
+#define MPP_EXTRA_INDICES_ ,:,:,:
+#define MPP_TYPE_ integer(INT_KIND)
+#include <mpp_global_sum.h>
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!              MPP_GLOBAL_FIELD: get global field from domain field           !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r8_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_r8_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_r8_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_r8_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_r8_2d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#include <mpp_global_field.h>
+
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_c8_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_c8_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_c8_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_c8_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_c8_2d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#include <mpp_global_field.h>
+
+#ifndef no_8byte_integers
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i8_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_i8_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_i8_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_i8_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_i8_2d
+#define MPP_TYPE_ integer(LONG_KIND)
+#include <mpp_global_field.h>
+
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l8_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_l8_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_l8_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_l8_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_l8_2d
+#define MPP_TYPE_ logical(LONG_KIND)
+#include <mpp_global_field.h>
+#endif
+
+#ifndef no_4byte_reals
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r4_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_r4_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_r4_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_r4_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_r4_2d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#include <mpp_global_field.h>
+#endif
+
+#ifndef no_4byte_cmplx
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_c4_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_c4_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_c4_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_c4_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_c4_2d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#include <mpp_global_field.h>
+#endif
+
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i4_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_i4_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_i4_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_i4_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_i4_2d
+#define MPP_TYPE_ integer(INT_KIND)
+#include <mpp_global_field.h>
+
+#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l4_2d
+#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_l4_3d
+#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_l4_4d
+#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_l4_5d
+#define MPP_GLOBAL1D_FIELD_2D_ mpp_global_field1D_l4_2d
+#define MPP_TYPE_ logical(INT_KIND)
+#include <mpp_global_field.h>
+
+end module mpp_domains_mod
+
+#ifdef test_mpp_domains
+program mpp_domains_test
+  use mpp_mod
+  use mpp_domains_mod
+  implicit none
+  integer :: pe, npes
+  integer :: nx=128, ny=128, nz=40, halo=2, stackmax=32768
+  real, dimension(:,:,:), allocatable :: global, gcheck
+  integer :: unit=7
+  logical :: debug=.FALSE., opened
+  namelist / mpp_domains_nml / nx, ny, nz, halo, stackmax, debug
+  integer :: i, j, k
+  integer :: layout(2)
+  integer :: is, ie, js, je, isd, ied, jsd, jed
+  integer :: id
+
+  call mpp_init()
+
+  call mpp_set_warn_level(FATAL)
+!possibly open a file called mpp_domains.nml
+  do
+     inquire( unit=unit, opened=opened )
+     if( .NOT.opened )exit
+     unit = unit + 1
+     if( unit.EQ.100 )call mpp_error( FATAL, 'Unable to locate unit number.' )
+  end do
+  open( unit=unit, status='OLD', file='mpp_domains.nml', err=10 )
+  read( unit,mpp_domains_nml )
+  close(unit)
+10 continue
+
+  pe = mpp_pe()
+  npes = mpp_npes()
+
+  if( debug )then
+      call mpp_domains_init(MPP_DEBUG)
+  else
+      call mpp_domains_init(MPP_DOMAIN_TIME)
+  end if
+  call mpp_domains_set_stack_size(stackmax)
+
+  if( pe.EQ.mpp_root_pe() )print '(a,5i4)', 'npes, nx, ny, nz, halo=', npes, nx, ny, nz, halo
+
+  allocate( global(1-halo:nx+halo,1-halo:ny+halo,nz) )
+  allocate( gcheck(nx,ny,nz) )
+
+!fill in global array: with k.iiijjj
+  do k = 1,nz
+     do j = 1,ny
+        do i = 1,nx
+           global(i,j,k) = k + i*1e-3 + j*1e-6
+        end do
+     end do
+  end do
+
+  call test_halo_update( 'Simple' ) !includes global field, global sum tests
+  call test_halo_update( 'Cyclic' )
+  call test_halo_update( 'Folded' ) !includes vector field test
+
+  call test_redistribute( 'Complete pelist' )
+  call test_redistribute( 'Overlap  pelist' )
+  call test_redistribute( 'Disjoint pelist' )
+  
+  call mpp_domains_exit()
+  call mpp_exit()
+
+contains
+
+  subroutine test_redistribute( type )
+!test redistribute between two domains
+    character(len=*), intent(in) :: type
+    type(domain2D) :: domainx, domainy
+    real, allocatable, dimension(:,:,:) :: x, y
+    integer, allocatable :: pelist(:)
+    integer :: pemax
+
+    pemax = npes/2              !the partial pelist will run from 0...pemax
+
+!select pelists
+    select case(type)
+    case( 'Complete pelist' )
+!both pelists run from 0...npes-1
+        allocate( pelist(0:npes-1) )
+        pelist = (/ (i,i=0,npes-1) /)
+        call mpp_declare_pelist( pelist )
+    case( 'Overlap  pelist' )
+!one pelist from 0...pemax, other from 0...npes-1
+        allocate( pelist(0:pemax) )
+        pelist = (/ (i,i=0,pemax) /)
+        call mpp_declare_pelist( pelist )
+    case( 'Disjoint pelist' )
+!one pelist from 0...pemax, other from pemax+1...npes-1
+        if( pemax+1.GE.npes )return
+        allocate( pelist(0:pemax) )
+        pelist = (/ (i,i=0,pemax) /)
+        call mpp_declare_pelist( pelist )
+        call mpp_declare_pelist( (/ (i,i=pemax+1,npes-1) /))
+    case default
+        call mpp_error( FATAL, 'TEST_REDISTRIBUTE: no such test: '//type )
+    end select
+
+!set up x and y arrays
+    select case(type)
+    case( 'Complete pelist' )
+!set up x array
+        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
+        call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
+        call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
+        call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
+        allocate( x(isd:ied,jsd:jed,nz) )
+        x = 0.
+        x(is:ie,js:je,:) = global(is:ie,js:je,:)
+!set up y array
+        call mpp_define_domains( (/1,nx,1,ny/), (/npes,1/), domainy, name=type )
+        call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
+        call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
+        allocate( y(isd:ied,jsd:jed,nz) )
+        y = 0.
+    case( 'Overlap  pelist' )
+!one pelist from 0...pemax, other from 0...npes-1
+!set up x array
+        call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
+        call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
+        call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
+        call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
+        allocate( x(isd:ied,jsd:jed,nz) )
+        x = 0.
+        x(is:ie,js:je,:) = global(is:ie,js:je,:)
+!set up y array
+        if( ANY(pelist.EQ.pe) )then
+            call mpp_set_current_pelist(pelist)
+            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
+            call mpp_define_domains( (/1,nx,1,ny/), layout, domainy, name=type )
+            call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
+            call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
+            allocate( y(isd:ied,jsd:jed,nz) )
+            y = 0.
+        end if
+    case( 'Disjoint pelist' )
+!one pelist from 0...pemax, other from pemax+1...npes-1
+
+!set up y array
+        if( ANY(pelist.EQ.pe) )then
+            call mpp_set_current_pelist(pelist)
+            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
+            call mpp_define_domains( (/1,nx,1,ny/), layout, domainy, name=type )
+            call mpp_get_compute_domain( domainy, is,  ie,  js,  je  )
+            call mpp_get_data_domain   ( domainy, isd, ied, jsd, jed )
+            allocate( y(isd:ied,jsd:jed,nz) )
+            y = 0.
+        else
+!set up x array
+            call mpp_set_current_pelist( (/ (i,i=pemax+1,npes-1) /) )
+            call mpp_define_layout( (/1,nx,1,ny/), mpp_npes(), layout )
+            call mpp_define_domains( (/1,nx,1,ny/), layout, domainx, name=type )
+            call mpp_get_compute_domain( domainx, is,  ie,  js,  je  )
+            call mpp_get_data_domain   ( domainx, isd, ied, jsd, jed )
+            allocate( x(isd:ied,jsd:jed,nz) )
+            x = 0.
+            x(is:ie,js:je,:) = global(is:ie,js:je,:)
+         end if
+    end select
+
+!go global and redistribute
+    call mpp_set_current_pelist()
+    call mpp_broadcast_domain(domainx)
+    call mpp_broadcast_domain(domainy)
+
+    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+    call mpp_clock_begin(id)
+    call mpp_redistribute( domainx, x, domainy, y )
+    call mpp_clock_end  (id)
+
+!check answers on pelist
+    if( ANY(pelist.EQ.pe) )then
+        call mpp_set_current_pelist(pelist)
+        call mpp_global_field( domainy, y, gcheck )
+        call compare_checksums( global(1:nx,1:ny,:), gcheck, type )
+    end if
+
+    call mpp_set_current_pelist()
+    call mpp_sync()
+
+    return
+  end subroutine test_redistribute
+
+  subroutine test_halo_update( type )
+    character(len=*), intent(in) :: type
+    real, allocatable, dimension(:,:,:) :: x, y
+    type(domain2D) :: domain
+    real :: lsum, gsum
+    
+    call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
+    select case(type)
+    case( 'Simple' )
+        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo, name=type )
+        global(1-halo:0,    :,:) = 0
+        global(nx+1:nx+halo,:,:) = 0
+        global(:,    1-halo:0,:) = 0
+        global(:,ny+1:ny+halo,:) = 0
+    case( 'Cyclic' )
+        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo, &
+             xflags=CYCLIC_GLOBAL_DOMAIN, yflags=CYCLIC_GLOBAL_DOMAIN, name=type )
+        global(1-halo:0,    1:ny,:) = global(nx-halo+1:nx,1:ny,:)
+        global(nx+1:nx+halo,1:ny,:) = global(1:halo,      1:ny,:)
+        global(1-halo:nx+halo,    1-halo:0,:) = global(1-halo:nx+halo,ny-halo+1:ny,:)
+        global(1-halo:nx+halo,ny+1:ny+halo,:) = global(1-halo:nx+halo,1:halo,      :)
+    case( 'Folded' )
+        call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo, &
+             xflags=CYCLIC_GLOBAL_DOMAIN, yflags=FOLD_NORTH_EDGE, name=type )
+        global(1-halo:0,    1:ny,:) = global(nx-halo+1:nx,1:ny,:)
+        global(nx+1:nx+halo,1:ny,:) = global(1:halo,      1:ny,:)
+        global(1-halo:nx+halo,ny+1:ny+halo,:) = global(nx+halo:1-halo:-1,ny:ny-halo+1:-1,:)
+        global(1-halo:nx+halo,1-halo:0,:) = 0
+    case default
+        call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type )
+    end select
+
+!set up x array
+    call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
+    call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
+    allocate( x(isd:ied,jsd:jed,nz) )
+    x = 0.
+    x(is:ie,js:je,:) = global(is:ie,js:je,:)
+
+!partial update
+    id = mpp_clock_id( type//' partial', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+    call mpp_clock_begin(id)
+    call mpp_update_domains( x, domain, NUPDATE+EUPDATE )
+    call mpp_clock_end  (id)
+    call compare_checksums( x(is:ied,js:jed,:), global(is:ied,js:jed,:), type//' partial' )
+
+!full update
+    id = mpp_clock_id( type, flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+    call mpp_clock_begin(id)
+    call mpp_update_domains( x, domain )
+    call mpp_clock_end  (id)
+    call compare_checksums( x, global(isd:ied,jsd:jed,:), type )
+
+    select case(type)           !extra tests
+    case( 'Simple' )
+
+!test mpp_global_field
+        id = mpp_clock_id( type//' global field', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+        call mpp_clock_begin(id)
+        call mpp_global_field( domain, x, gcheck )
+        call mpp_clock_end  (id)
+!compare checksums between global and x arrays
+        call compare_checksums( global(1:nx,1:ny,:), gcheck, 'mpp_global_field' )
+
+!test mpp_global_sum
+        gsum = sum( global(1:nx,1:ny,:) )
+        id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+        call mpp_clock_begin(id)
+        lsum = mpp_global_sum( domain, x )
+        call mpp_clock_end  (id)
+        if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', 'Fast sum=', lsum, gsum
+!test exact mpp_global_sum
+        id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+        call mpp_clock_begin(id)
+        lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM )
+        call mpp_clock_end  (id)
+        if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', 'Bitwise-exact sum=', lsum, gsum
+    case( 'Folded' )!test vector update: folded, with sign flip at fold
+!fill in folded north edge, cyclic east and west edge
+        global(1-halo:0,    1:ny,:) = global(nx-halo+1:nx,1:ny,:)
+        global(nx+1:nx+halo,1:ny,:) = global(1:halo,      1:ny,:)
+        global(1-halo:nx+halo-1,ny+1:ny+halo,:) = -global(nx+halo-1:1-halo:-1,ny-1:ny-halo:-1,:)
+        global(nx+halo,ny+1:ny+halo,:) = -global(nx-halo,ny-1:ny-halo:-1,:)
+        global(1-halo:nx+halo,1-halo:0,:) = 0
+
+        x = 0.
+        x(is:ie,js:je,:) = global(is:ie,js:je,:)
+!set up y array
+        allocate( y(isd:ied,jsd:jed,nz) )
+        y = x
+        id = mpp_clock_id( type//' vector', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED )
+        call mpp_clock_begin(id)
+        call mpp_update_domains( x, y, domain, gridtype=BGRID_NE )
+        call mpp_clock_end  (id)
+!redundant points must be equal and opposite
+        global(nx/2,ny,:) = 0.  !pole points must have 0 velocity
+        global(nx  ,ny,:) = 0.  !pole points must have 0 velocity
+        global(nx/2+1:nx-1, ny,:) = -global(nx/2-1:1:-1, ny,:)
+        global(1-halo:0,    ny,:) = -global(nx-halo+1:nx,ny,:)
+        global(nx+1:nx+halo,ny,:) = -global(1:halo,      ny,:)
+        call compare_checksums( x, global(isd:ied,jsd:jed,:), type//' X' )
+        call compare_checksums( y, global(isd:ied,jsd:jed,:), type//' Y' )
+    end select
+    return
+  end subroutine test_halo_update
+
+  subroutine compare_checksums( a, b, string )
+    real, intent(in), dimension(:,:,:) :: a, b
+    character(len=*), intent(in) :: string
+    integer :: i, j
+
+    call mpp_sync()
+    i = mpp_chksum( a, (/pe/) )
+    j = mpp_chksum( b, (/pe/) )
+    if( i.EQ.j )then
+        if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': OK.' )
+    else
+        call mpp_error( FATAL, trim(string)//': chksums are not OK.' )
+    end if
+  end subroutine compare_checksums
+end program mpp_domains_test
+#endif
Index: CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_io_mod.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_io_mod.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_io_mod.F90	(revision 1677)
@@ -0,0 +1,3118 @@
+!-----------------------------------------------------------------------
+!                 Parallel I/O for message-passing codes
+!
+! AUTHOR: V. Balaji (vbalaji@noaa.gov)
+!         Princeton University/GFDL
+!
+! MODIFICATIONS: Reiner Vogelsang (reiner@sgi.com)
+!
+! This program is free software; The author agrees that you can
+! redistribute and/or modify this version of the program under the
+! terms of the Lesser GNU General Public License as published
+! by the Free Software Foundation.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! Lesser GNU General Public License for more details
+! (http://www.gnu.org/copyleft/lesser.html).
+!-----------------------------------------------------------------------
+!#include <os.h>
+
+module mpp_io_mod
+  use mod_kinds_model
+  use mpp_mod
+  use mpp_domains_mod
+  implicit none
+#include <os.h>
+  private
+
+  character(len=128), private :: version= &
+       '$Id: mpp_io_mod.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $'
+  character(len=128), private :: tagname= &
+       '$Name: ipslcm5a $'
+
+  integer, private :: pe, npes
+
+  type, public :: axistype
+     private
+     character(len=128) :: name
+     character(len=128) :: units
+     character(len=256) :: longname
+     character(len=8) :: cartesian
+     integer :: sense, len           !+/-1, depth or height?
+     type(domain1D) :: domain !if pointer is associated, it is a distributed data axis
+     real, pointer :: data(:)   !axis values (not used if time axis)
+     integer :: id, did, type, natt         !id is the "variable ID", did is the "dimension ID": netCDF requires 2 IDs for axes
+     type(atttype), pointer :: Att(:)
+  end type axistype
+
+  type, public :: atttype
+     integer :: type, len
+     character(len=128) :: name
+     character(len=256) :: catt
+! just use type conversion for integers
+     real, pointer :: fatt(:)
+  end type atttype
+
+  type, public :: fieldtype
+     private
+     character(len=128) :: name
+     character(len=128) :: units
+     character(len=256) :: longname
+     real :: min, max, missing, fill, scale, add
+     integer :: pack
+     type(axistype), pointer :: axes(:) !axes associated with field
+!size, time_axis_index redundantly hold info already contained in axes
+!it's clunky and inelegant, but required so that axes can be shared among multiple files
+     integer, pointer :: size(:)
+     integer :: time_axis_index
+     integer :: id, type, natt, ndim
+     type(atttype), pointer :: Att(:)
+  end type fieldtype
+
+  type, private :: filetype
+     character(len=256) :: name
+     integer :: action, format, access, threading, fileset, record, ncid
+     logical :: opened, initialized, nohdrs
+     integer :: time_level
+     real(DOUBLE_KIND) :: time
+     integer :: id             !variable ID of time axis associated with file (only one time axis per file)
+     integer :: recdimid             !dim ID of time axis associated with file (only one time axis per file)
+!
+! time axis values are stored here instead of axis%data since mpp_write
+! assumes these values are not time values. Not used in mpp_write
+!
+     real(DOUBLE_KIND), pointer :: time_values(:)
+
+! additional elements of filetype for mpp_read (ignored for mpp_write)
+     integer :: ndim, nvar, natt  ! number of dimensions, non-dimension variables and global attributes
+! redundant axis types stored here and in associated fieldtype
+! some axes are not used by any fields, i.e. "edges"
+     type(axistype), pointer  :: axis(:)
+     type(fieldtype), pointer :: var(:)
+     type(atttype), pointer   :: att(:)
+  end type filetype
+
+  type(axistype), public  :: default_axis !provided to users with default components
+  type(fieldtype), public :: default_field !provided to users with default components
+  type(atttype), public   :: default_att !provided to users with default components
+!action on open
+  integer, parameter, public :: MPP_WRONLY=100, MPP_RDONLY=101, MPP_APPEND=102, MPP_OVERWR=103
+!format
+  integer, parameter, public :: MPP_ASCII=200,  MPP_IEEE32=201, MPP_NATIVE=202, MPP_NETCDF=203
+!access
+  integer, parameter, public :: MPP_SEQUENTIAL=300, MPP_DIRECT=301
+!threading, fileset
+  integer, parameter, public :: MPP_SINGLE=400, MPP_MULTI=401
+!action on close
+  integer, parameter, public :: MPP_DELETE=501, MPP_COLLECT=502
+
+  type(filetype), private, allocatable :: mpp_file(:)
+  integer, private :: records_per_pe
+  integer, private :: maxunits, unit_begin, unit_end
+  integer, private :: varnum=0
+  integer, private :: error
+  character(len=256) :: text
+!null unit: returned by PEs not participating in IO after a collective call
+  integer, parameter, private :: NULLUNIT=-1
+  real(DOUBLE_KIND), parameter, private :: NULLTIME=-1.
+  logical, private :: verbose=.FALSE., debug=.FALSE., module_is_initialized=.FALSE.
+
+  real(DOUBLE_KIND), private, allocatable :: mpp_io_stack(:)
+  integer, private :: mpp_io_stack_size=0, mpp_io_stack_hwm=0
+  
+  interface mpp_write_meta
+     module procedure mpp_write_meta_var
+     module procedure mpp_write_meta_scalar_r
+     module procedure mpp_write_meta_scalar_i
+     module procedure mpp_write_meta_axis
+     module procedure mpp_write_meta_field
+     module procedure mpp_write_meta_global
+     module procedure mpp_write_meta_global_scalar_r
+     module procedure mpp_write_meta_global_scalar_i
+  end interface
+
+  interface mpp_copy_meta
+     module procedure mpp_copy_meta_axis
+     module procedure mpp_copy_meta_field
+     module procedure mpp_copy_meta_global
+  end interface
+     
+  interface mpp_write
+     module procedure mpp_write_2ddecomp_r1d
+     module procedure mpp_write_2ddecomp_r2d
+     module procedure mpp_write_2ddecomp_r3d
+     module procedure mpp_write_r0D
+     module procedure mpp_write_r1D
+     module procedure mpp_write_r2D
+     module procedure mpp_write_r3D
+     module procedure mpp_write_r4D
+     module procedure mpp_write_axis
+  end interface
+
+  interface mpp_read
+     module procedure mpp_read_2ddecomp_r1d
+     module procedure mpp_read_2ddecomp_r2d
+     module procedure mpp_read_2ddecomp_r3d
+     module procedure mpp_read_r0D
+     module procedure mpp_read_r1D
+     module procedure mpp_read_r2D
+     module procedure mpp_read_r3D
+  end interface
+
+  interface mpp_get_id
+     module procedure mpp_get_axis_id
+     module procedure mpp_get_field_id
+  end interface
+
+  interface mpp_get_atts
+     module procedure mpp_get_global_atts
+     module procedure mpp_get_field_atts
+     module procedure mpp_get_axis_atts
+  end interface
+
+  interface mpp_modify_meta
+!     module procedure mpp_modify_att_meta
+     module procedure mpp_modify_field_meta
+     module procedure mpp_modify_axis_meta
+  end interface
+
+  public :: mpp_close, mpp_flush, mpp_get_iospec, mpp_get_id, mpp_get_ncid, mpp_get_unit_range, mpp_io_init, mpp_io_exit, &
+            mpp_open, mpp_set_unit_range, mpp_write, mpp_write_meta, mpp_read, mpp_get_info, mpp_get_atts, &
+            mpp_get_fields, mpp_get_times, mpp_get_axes, mpp_copy_meta, mpp_get_recdimid, mpp_get_axis_data, mpp_modify_meta, &
+            mpp_io_set_stack_size, mpp_get_field_index
+
+  private :: read_record, mpp_read_meta, lowercase
+
+#ifdef use_netCDF
+#include <netcdf.inc>
+#endif
+
+  contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!               mpp_io_init: initialize parallel I/O                   !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    subroutine mpp_io_init( flags, maxunit,maxresunit )
+      integer, intent(in), optional :: flags, maxunit ,maxresunit
+!rv
+!rv I introduced the variable to indentify that the top max_reserved_units 
+!rv of maxunits are reserved for OASIS coupler specific things like the trace
+!rv files. This variable is active only if one specifies explicitely  the
+!rv argument maxunit.
+      integer::max_reserved_units
+!rv
+!initialize IO package: initialize mpp_file array, set valid range of units for fortran IO
+
+      if( module_is_initialized )return
+      call mpp_init(flags)           !if mpp_init has been called, this call will merely return
+      pe = mpp_pe()
+      npes = mpp_npes()
+      call mpp_domains_init(flags)
+
+      maxunits = 64
+      if( PRESENT(maxunit) )maxunits = maxunit
+
+      max_reserved_units=5
+      if( PRESENT(maxresunit) )max_reserved_units = maxresunit
+
+      if( PRESENT(flags) )then
+          debug   = flags.EQ.MPP_DEBUG
+          verbose = flags.EQ.MPP_VERBOSE .OR. debug
+      end if
+!initialize default_field
+      default_field%name = 'noname'
+      default_field%units = 'nounits'
+      default_field%longname = 'noname'
+      default_field%id = -1
+      default_field%type = -1
+      default_field%natt = -1
+      default_field%ndim = -1
+!largest possible 4-byte reals
+      default_field%min = -huge(1._4)
+      default_field%max =  huge(1._4)
+      default_field%missing = -1e36
+      default_field%fill = -1e36
+      default_field%scale = 0.
+      default_field%add = huge(1._4)
+      default_field%pack = 1
+      default_field%time_axis_index = -1 !this value will never match any index
+! Initialize default axis
+      default_axis%name = 'noname'
+      default_axis%units = 'nounits'
+      default_axis%longname = 'noname'
+      default_axis%cartesian = 'none'
+      default_axis%sense = 0
+      default_axis%len = -1
+      default_axis%id = -1
+      default_axis%did = -1
+      default_axis%type = -1
+      default_axis%natt = -1
+! Initialize default attribute
+      default_att%name = 'noname'
+      default_att%type = -1
+      default_att%len = -1
+      default_att%catt = 'none'
+      
+!up to MAXUNITS fortran units and MAXUNITS netCDF units are supported
+!file attributes (opened, format, access, threading, fileset) are saved against the unit number
+!external handles to netCDF units are saved from maxunits+1:2*maxunits
+      allocate( mpp_file(NULLUNIT:2*maxunits) ) !starts at NULLUNIT=-1, used by non-participant PEs in single-threaded I/O
+      mpp_file(:)%name   = ' '
+      mpp_file(:)%action    = -1
+      mpp_file(:)%format    = -1
+      mpp_file(:)%threading = -1
+      mpp_file(:)%fileset   = -1
+      mpp_file(:)%record    = -1
+      mpp_file(:)%ncid      = -1
+      mpp_file(:)%opened = .FALSE.
+      mpp_file(:)%initialized = .FALSE.
+      mpp_file(:)%time_level = 0
+      mpp_file(:)%time = NULLTIME
+      mpp_file(:)%id = -1
+!
+      mpp_file(:)%ndim = -1
+      mpp_file(:)%nvar = -1
+!NULLUNIT "file" is always single-threaded, open and initialized (to pass checks in mpp_write)
+      mpp_file(NULLUNIT)%threading = MPP_SINGLE
+      mpp_file(NULLUNIT)%opened = .TRUE.
+      mpp_file(NULLUNIT)%initialized = .TRUE.
+!declare the stdunits to be open
+      mpp_file(stdin ())%opened = .TRUE.
+      mpp_file(stdout())%opened = .TRUE.
+      mpp_file(stderr())%opened = .TRUE.
+      mpp_file(stdlog())%opened = .TRUE.
+!set range of allowed fortran unit numbers: could be compiler-dependent (should not overlap stdin/out/err)
+!
+!rv For OASIS 3 I consider the top max_reserved_units to be excluded from
+!rv the list of files ito closed during mpp_io_exit.
+!rv      call mpp_set_unit_range( 7, maxunits )
+      if(present(maxunit)) then
+        call mpp_set_unit_range( 7, maxunits-max_reserved_units )
+      else
+        call mpp_set_unit_range( 7, maxunits )
+      endif
+!rv
+
+      if( pe.EQ.mpp_root_pe() )then
+          write( stdlog(),'(/a)' )'MPP_IO module '//trim(version)
+#ifdef use_netCDF
+          text = NF_INQ_LIBVERS()
+          write( stdlog(),'(a)' )'Using netCDF library version '//trim(text)
+#endif
+      endif
+
+#ifdef CRAYPVP
+!we require every file to be assigned threadwise: PVPs default to global, and are reset here
+      call ASSIGN( 'assign -P thread p:%', error )
+#endif
+
+      call mpp_io_set_stack_size(131072) ! default initial value
+      call mpp_sync()
+      module_is_initialized = .TRUE.
+      return
+    end subroutine mpp_io_init
+
+    subroutine mpp_io_exit()
+      integer :: unit
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_IO_EXIT: must first call mpp_io_init.' )
+!close all open fortran units
+      do unit = unit_begin,unit_end
+         if( mpp_file(unit)%opened )call FLUSH(unit)
+      end do
+      call mpp_sync()
+      do unit = unit_begin,unit_end
+         if( mpp_file(unit)%opened )close(unit)
+      end do
+#ifdef use_netCDF
+!close all open netCDF units
+      do unit = maxunits+1,2*maxunits
+         if( mpp_file(unit)%opened )error = NF_CLOSE(mpp_file(unit)%ncid)
+      end do
+#endif
+
+      call mpp_max(mpp_io_stack_hwm)
+      
+      if( pe.EQ.mpp_root_pe() )then
+!          write( stdout,'(/a)' )'Exiting MPP_IO module...'
+!          write( stdout,* )'MPP_IO_STACK high water mark=', mpp_io_stack_hwm
+      end if
+      deallocate(mpp_file)
+      module_is_initialized = .FALSE.
+      return
+    end subroutine mpp_io_exit
+
+    subroutine mpp_io_set_stack_size(n)
+!set the mpp_io_stack variable to be at least n LONG words long
+      integer, intent(in) :: n
+      character(len=8) :: text
+
+      if( n.GT.mpp_io_stack_size .AND. allocated(mpp_io_stack) )deallocate(mpp_io_stack)
+      if( .NOT.allocated(mpp_io_stack) )then
+          allocate( mpp_io_stack(n) )
+          mpp_io_stack_size = n
+          write( text,'(i8)' )n	
+          if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, 'MPP_IO_SET_STACK_SIZE: stack size set to '//text//'.' )	
+      end if
+
+      return
+    end subroutine mpp_io_set_stack_size
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                            !
+!           OPENING AND CLOSING FILES: mpp_open() and mpp_close()            !
+!                                                                            !
+! mpp_open( unit, file, action, form, access, threading, &                   !
+!           fileset, iospec, nohdrs, recl, pelist )                          !
+!      integer, intent(out) :: unit                                          !
+!      character(len=*), intent(in) :: file                                  !
+!      integer, intent(in), optional :: action, form, access, threading,     !
+!                                       fileset, recl                        !
+!      character(len=*), intent(in), optional :: iospec                      !
+!      logical, intent(in), optional :: nohdrs                               !
+!      integer, optional, intent(in) :: pelist(:) !default ALL               !
+!                                                                            !
+!  unit is intent(OUT): always _returned_by_ mpp_open()                      !
+!  file is the filename: REQUIRED                                            !
+!    we append .nc to filename if it is a netCDF file                        !
+!    we append .<pppp> to filename if fileset is private (pppp is PE number) !
+!  iospec is a system hint for I/O organization                              !
+!         e.g assign(1) on SGI/Cray systems.                                 !
+!  if nohdrs is .TRUE. headers are not written on non-netCDF writes.         !
+!  nohdrs has no effect when action=MPP_RDONLY|MPP_APPEND                    !
+!                    or when form=MPP_NETCDF                                 !
+! FLAGS:                                                                     !
+!    action is one of MPP_RDONLY, MPP_APPEND or MPP_WRONLY                   !
+!    form is one of MPP_ASCII:  formatted read/write                         !
+!                   MPP_NATIVE: unformatted read/write, no conversion        !
+!                   MPP_IEEE32: unformatted read/write, conversion to IEEE32 !
+!                   MPP_NETCDF: unformatted read/write, conversion to netCDF !
+!    access is one of MPP_SEQUENTIAL or MPP_DIRECT (ignored for netCDF)      !
+!      RECL argument is REQUIRED for direct access IO                        !
+!    threading is one of MPP_SINGLE or MPP_MULTI                             !
+!      single-threaded IO in a multi-PE run is done by PE0                   !
+!    fileset is one of MPP_MULTI and MPP_SINGLE                              !
+!      fileset is only used for multi-threaded I/O                           !
+!      if all I/O PEs in <pelist> use a single fileset,                      !
+!              they write to the same file                                   !
+!      if all I/O PEs in <pelist> use a multi  fileset,                      !
+!              they each write an independent file                           !
+!  recl is the record length in bytes                                        !
+!  pelist is the list of I/O PEs (currently ALL)                             !
+!                                                                            !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    subroutine mpp_open( unit, file, action, form, access, threading, &
+                                     fileset, iospec, nohdrs, recl, pelist )
+      integer, intent(out) :: unit
+      character(len=*), intent(in) :: file
+      integer, intent(in), optional :: action, form, access, threading, &
+           fileset, recl
+      character(len=*), intent(in), optional :: iospec
+      logical, intent(in), optional :: nohdrs
+      integer, intent(in), optional :: pelist(:) !default ALL
+
+      character(len=16) :: act, acc, for, pos
+      integer :: action_flag, form_flag, access_flag, threading_flag, fileset_flag, length
+      logical :: exists
+      character(len=64) :: filespec
+      type(axistype) :: unlim    !used by netCDF with mpp_append
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_OPEN: must first call mpp_io_init.' )
+!set flags
+      action_flag = MPP_WRONLY        !default
+      if( PRESENT(action) )action_flag = action
+      form_flag = MPP_ASCII
+      if( PRESENT(form) )form_flag = form
+#ifndef use_netCDF
+      if( form_flag.EQ.MPP_NETCDF ) &
+           call mpp_error( FATAL, 'MPP_OPEN: To open a file with form=MPP_NETCDF, you must compile mpp_io with -Duse_netCDF.' )
+#endif
+      access_flag = MPP_SEQUENTIAL
+      if( PRESENT(access) )access_flag = access
+      threading_flag = MPP_SINGLE
+      if( npes.GT.1 .AND. PRESENT(threading) )threading_flag = threading
+      fileset_flag = MPP_MULTI
+      if( PRESENT(fileset) )fileset_flag = fileset
+      if( threading_flag.EQ.MPP_SINGLE )fileset_flag = MPP_SINGLE
+
+!get a unit number
+      if( threading_flag.EQ.MPP_SINGLE )then
+          if( pe.NE.mpp_root_pe() .AND. action_flag.NE.MPP_RDONLY )then
+              unit = NULLUNIT           !PEs not participating in IO from this mpp_open() will return this value for unit
+              return
+          end if
+      end if
+      if( form_flag.EQ.MPP_NETCDF )then
+          do unit = maxunits+1,2*maxunits
+             if( .NOT.mpp_file(unit)%opened )exit
+          end do
+          if( unit.GT.2*maxunits )call mpp_error( FATAL, 'MPP_OPEN: too many open netCDF files.' )
+      else
+          do unit = unit_begin, unit_end
+             inquire( unit,OPENED=mpp_file(unit)%opened )
+             if( .NOT.mpp_file(unit)%opened )exit
+          end do
+          if( unit.GT.unit_end )call mpp_error( FATAL, 'MPP_OPEN: no available units.' )
+      end if
+
+!get a filename
+      text = file
+      length = len(file)
+
+      if( form_flag.EQ.MPP_NETCDF.AND. file(length-2:length) /= '.nc' ) &
+         text = trim(file)//'.nc'
+         
+      if( fileset_flag.EQ.MPP_MULTI )write( text,'(a,i4.4)' )trim(text)//'.', pe
+      mpp_file(unit)%name = text
+      if( verbose )print '(a,2i3,x,a,5i5)', 'MPP_OPEN: PE, unit, filename, action, format, access, threading, fileset=', &
+           pe, unit, trim(mpp_file(unit)%name), action_flag, form_flag, access_flag, threading_flag, fileset_flag
+
+!action: read, write, overwrite, append: act and pos are ignored by netCDF
+      if( action_flag.EQ.MPP_RDONLY )then
+          act = 'READ'
+          pos = 'REWIND'
+!          if( form_flag.EQ.MPP_NETCDF )call mpp_error( FATAL, 'MPP_OPEN: only writes are currently supported with netCDF.' )
+      else if( action_flag.EQ.MPP_WRONLY .OR. action_flag.EQ.MPP_OVERWR )then
+          act = 'WRITE'
+          pos = 'REWIND'
+      else if( action_flag.EQ.MPP_APPEND )then
+          act = 'WRITE'
+          pos = 'APPEND'
+      else
+          call mpp_error( FATAL, 'MPP_OPEN: action must be one of MPP_WRONLY, MPP_APPEND or MPP_RDONLY.' )
+      end if
+
+!access: sequential or direct: ignored by netCDF
+      if( form_flag.NE.MPP_NETCDF )then
+          if( access_flag.EQ.MPP_SEQUENTIAL )then
+              acc = 'SEQUENTIAL'
+          else if( access_flag.EQ.MPP_DIRECT )then
+              acc = 'DIRECT'
+              if( form_flag.EQ.MPP_ASCII )call mpp_error( FATAL, 'MPP_OPEN: formatted direct access I/O is prohibited.' )
+              if( .NOT.PRESENT(recl) ) &
+                   call mpp_error( FATAL, 'MPP_OPEN: recl (record length in bytes) must be specified with access=MPP_DIRECT.' )
+              mpp_file(unit)%record = 1
+              records_per_pe = 1 !each PE writes 1 record per mpp_write
+          else
+              call mpp_error( FATAL, 'MPP_OPEN: access must be one of MPP_SEQUENTIAL or MPP_DIRECT.' )
+          end if
+      end if
+
+!threading: SINGLE or MULTI
+      if( threading_flag.EQ.MPP_MULTI )then
+!fileset: MULTI or SINGLE (only for multi-threaded I/O
+          if( fileset_flag.EQ.MPP_SINGLE )then
+              if( form_flag.EQ.MPP_NETCDF .AND. act.EQ.'WRITE' ) &
+                   call mpp_error( FATAL, 'MPP_OPEN: netCDF currently does not support single-file multi-threaded output.' )
+
+#ifdef _CRAYT3E
+              call ASSIGN( 'assign -I -F global.privpos f:'//trim(mpp_file(unit)%name), error )
+#endif
+          else if( fileset_flag.NE.MPP_MULTI )then
+              call mpp_error( FATAL, 'MPP_OPEN: fileset must be one of MPP_MULTI or MPP_SINGLE.' )
+          end if
+      else if( threading_flag.NE.MPP_SINGLE )then
+          call mpp_error( FATAL, 'MPP_OPEN: threading must be one of MPP_SINGLE or MPP_MULTI.' )
+      end if
+
+!apply I/O specs before opening the file
+!note that -P refers to the scope of a fortran unit, which is always thread-private even if file is shared
+#ifdef CRAYPVP
+      call ASSIGN( 'assign -I -P thread  f:'//trim(mpp_file(unit)%name), error )
+#endif
+#ifdef _CRAYT3E
+      call ASSIGN( 'assign -I -P private f:'//trim(mpp_file(unit)%name), error )
+#endif
+      if( PRESENT(iospec) )then
+!iospec provides hints to the system on how to organize I/O
+!on Cray systems this is done through 'assign', see assign(1) and assign(3F)
+!on other systems this will be expanded as needed
+!no error checks here on whether the supplied iospec is valid
+#ifdef SGICRAY
+          call ASSIGN( 'assign -I '//trim(iospec)//' f:'//trim(mpp_file(unit)%name), error )
+          if( form_flag.EQ.MPP_NETCDF )then
+!for netCDF on SGI/Cray systems we pass it to the environment variable NETCDF_XFFIOSPEC
+!ideally we should parse iospec, pass the argument of -F to NETCDF_FFIOSPEC, and the rest to NETCDF_XFFIOSPEC
+!maybe I'll get around to it someday
+!PXFSETENV is a POSIX-standard routine for setting environment variables from fortran
+              call PXFSETENV( 'NETCDF_XFFIOSPEC', 0, trim(iospec), 0, 1, error )
+          end if
+#endif
+      end if
+
+!open the file as specified above for various formats
+      if( form_flag.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          if( action_flag.EQ.MPP_WRONLY )then
+              error = NF_CREATE( trim(mpp_file(unit)%name), NF_NOCLOBBER, mpp_file(unit)%ncid ); call netcdf_err(error)
+              if( verbose )print '(a,i3,i16)', 'MPP_OPEN: new netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
+          else if( action_flag.EQ.MPP_OVERWR )then
+              error = NF_CREATE( trim(mpp_file(unit)%name), NF_CLOBBER,   mpp_file(unit)%ncid ); call netcdf_err(error)
+              action_flag = MPP_WRONLY !after setting clobber, there is no further distinction btwn MPP_WRONLY and MPP_OVERWR
+              if( verbose )print '(a,i3,i16)', 'MPP_OPEN: overwrite netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
+          else if( action_flag.EQ.MPP_APPEND )then
+              error = NF_OPEN( trim(mpp_file(unit)%name), NF_WRITE, mpp_file(unit)%ncid ); call netcdf_err(error)
+!get the current time level of the file: writes to this file will be at next time level
+              error = NF_INQ_UNLIMDIM( mpp_file(unit)%ncid, unlim%did )
+              if( error.EQ.NF_NOERR )then
+                  error = NF_INQ_DIM( mpp_file(unit)%ncid, unlim%did, unlim%name, mpp_file(unit)%time_level )
+                  call netcdf_err(error)
+                  error = NF_INQ_VARID( mpp_file(unit)%ncid, unlim%name, mpp_file(unit)%id ); call netcdf_err(error)
+              end if
+              if( verbose )print '(a,i3,i16,i4)', 'MPP_OPEN: append to existing netCDF file: pe, ncid, time_axis_id=',&
+                   pe, mpp_file(unit)%ncid, mpp_file(unit)%id
+	  else if( action_flag.EQ.MPP_RDONLY )then
+	      error = NF_OPEN( trim(mpp_file(unit)%name), NF_NOWRITE, mpp_file(unit)%ncid ); call netcdf_err(error)
+	      if( verbose )print '(a,i3,i16,i4)', 'MPP_OPEN: opening existing netCDF file: pe, ncid, time_axis_id=',&
+                   pe, mpp_file(unit)%ncid, mpp_file(unit)%id
+              mpp_file(unit)%format=form_flag ! need this for mpp_read
+              call mpp_read_meta(unit)
+          end if
+          mpp_file(unit)%opened = .TRUE.
+#endif
+      else
+!format: ascii, native, or IEEE 32 bit
+          if( form_flag.EQ.MPP_ASCII )then
+              for = 'FORMATTED'
+          else if( form_flag.EQ.MPP_IEEE32 )then
+              for = 'UNFORMATTED'
+!assign -N is currently unsupported on SGI
+#ifdef _CRAY
+              call ASSIGN( 'assign -I -N ieee_32 f:'//trim(mpp_file(unit)%name), error )
+#endif
+          else if( form_flag.EQ.MPP_NATIVE )then
+              for = 'UNFORMATTED'
+          else
+              call mpp_error( FATAL, 'MPP_OPEN: form must be one of MPP_ASCII, MPP_NATIVE, MPP_IEEE32 or MPP_NETCDF.' )
+          end if
+          inquire( file=trim(mpp_file(unit)%name), EXIST=exists )
+          if( exists .AND. action_flag.EQ.MPP_WRONLY ) &
+               call mpp_error( WARNING, 'MPP_OPEN: File '//trim(mpp_file(unit)%name)//' opened WRONLY already exists!' )
+          if( action_flag.EQ.MPP_OVERWR )action_flag = MPP_WRONLY
+!perform the OPEN here
+          if( PRESENT(recl) )then
+              if( verbose )print '(2(x,a,i3),5(x,a),a,i8)', 'MPP_OPEN: PE=', pe, &
+                   'unit=', unit, trim(mpp_file(unit)%name), 'attributes=', trim(acc), trim(for), trim(act), ' RECL=', recl
+              open( unit, file=trim(mpp_file(unit)%name), access=acc, form=for, action=act, recl=recl )
+          else
+              if( verbose )print '(2(x,a,i3),6(x,a))',      'MPP_OPEN: PE=', pe, &
+                   'unit=', unit, trim(mpp_file(unit)%name), 'attributes=', trim(acc), trim(for), trim(pos), trim(act)
+              open( unit, file=trim(mpp_file(unit)%name), access=acc, form=for, action=act, position=pos )
+          end if
+!check if OPEN worked
+          inquire( unit,OPENED=mpp_file(unit)%opened )
+          if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_OPEN: error in OPEN() statement.' )
+      end if
+      mpp_file(unit)%action = action_flag
+      mpp_file(unit)%format = form_flag
+      mpp_file(unit)%access = access_flag
+      mpp_file(unit)%threading = threading_flag
+      mpp_file(unit)%fileset = fileset_flag
+      if( PRESENT(nohdrs) )mpp_file(unit)%nohdrs = nohdrs
+
+      if( action_flag.EQ.MPP_WRONLY )then
+          if( form_flag.NE.MPP_NETCDF .AND. access_flag.EQ.MPP_DIRECT )call mpp_write_meta( unit, 'record_length', ival=recl )
+!actual file name
+          call mpp_write_meta( unit, 'filename', cval=mpp_file(unit)%name )
+!MPP_IO package version
+          call mpp_write_meta( unit, 'MPP_IO_VERSION', cval=trim(version) )
+!filecount for multifileset
+          if( threading_flag.EQ.MPP_MULTI .AND. fileset_flag.EQ.MPP_MULTI ) &
+               call mpp_write_meta( unit, 'NumFilesInSet', ival=npes )
+      end if
+
+      return
+    end subroutine mpp_open
+
+    subroutine mpp_close( unit, action )
+      integer, intent(in) :: unit
+      integer, intent(in), optional :: action
+      character(len=8) :: status
+      logical :: collect
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOSE: must first call mpp_io_init.' )
+      if( unit.EQ.NULLUNIT )return !nothing was actually opened on this unit
+
+!action on close
+      status = 'KEEP'
+!collect is supposed to launch the post-processing collector tool for multi-fileset
+      collect = .FALSE.
+      if( PRESENT(action) )then
+          if( action.EQ.MPP_DELETE )then
+              status = 'DELETE'
+          else if( action.EQ.MPP_COLLECT )then
+              collect = .FALSE.         !should be TRUE but this is not yet ready
+              call mpp_error( WARNING, 'MPP_CLOSE: the COLLECT operation is not yet implemented.' )
+          else
+              call mpp_error( FATAL, 'MPP_CLOSE: action must be one of MPP_DELETE or MPP_COLLECT.' )
+          end if
+      end if
+      if( mpp_file(unit)%fileset.NE.MPP_MULTI )collect = .FALSE.
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          error = NF_CLOSE(mpp_file(unit)%ncid); call netcdf_err(error)
+#endif
+      else
+          close(unit,status=status)
+      end if
+#ifdef SGICRAY
+!this line deleted: since the FILENV is a shared file, this might cause a problem in
+! multi-threaded I/O if one PE does assign -R before another one has opened it.
+!      call ASSIGN( 'assign -R f:'//trim(mpp_file(unit)%name), error )
+#endif
+      mpp_file(unit)%name = ' '
+      mpp_file(unit)%action    = -1
+      mpp_file(unit)%format    = -1
+      mpp_file(unit)%access    = -1
+      mpp_file(unit)%threading = -1
+      mpp_file(unit)%fileset   = -1
+      mpp_file(unit)%record    = -1
+      mpp_file(unit)%ncid      = -1
+      mpp_file(unit)%opened = .FALSE.
+      mpp_file(unit)%initialized = .FALSE.
+      mpp_file(unit)%id = -1
+      mpp_file(unit)%time_level = 0
+      mpp_file(unit)%time = NULLTIME
+      return
+    end subroutine mpp_close
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                            !
+!                             MPP_WRITE_META                                 !
+!                                                                            !
+!This series of routines is used to describe the contents of the file        !
+!being written on <unit>. Each file can contain any number of fields,        !
+!which can be functions of 0-3 spatial axes and 0-1 time axes. Axis          !
+!descriptors are stored in the <axistype> structure and field                !
+!descriptors in the <fieldtype> structure.                                   !
+!                                                                            !
+!  type, public :: axistype                                                  !
+!     sequence                                                               !
+!     character(len=128) :: name                                             !
+!     character(len=128) :: units                                            !
+!     character(len=256) :: longname                                         !
+!     integer :: sense           !+/-1, depth or height?                     !
+!     type(domain1D) :: domain                                      !
+!     real, pointer :: data(:) !axis values (not used if time axis)          !
+!     integer :: id                                                          !
+!  end type axistype                                                         !
+!                                                                            !
+!  type, public :: fieldtype                                                 !
+!     sequence                                                               !
+!     character(len=128) :: name                                             !
+!     character(len=128) :: units                                            !
+!     character(len=256) :: longname                                         !
+!     real :: min, max, missing, fill, scale, add                            !
+!     type(axistype), pointer :: axis(:)                                     !
+!     integer :: id                                                          !
+!  end type fieldtype                                                        !
+!                                                                            !
+!The metadata contained in the type is always written for each axis and      !
+!field. Any other metadata one wishes to attach to an axis or field          !
+!can subsequently be passed to mpp_write_meta using the ID, as shown below.  !
+!                                                                            !
+!mpp_write_meta can take several forms:                                      !
+!                                                                            !
+!  mpp_write_meta( unit, name, rval=rval, pack=pack )                        !
+!  mpp_write_meta( unit, name, ival=ival )                                   !
+!  mpp_write_meta( unit, name, cval=cval )                                   !
+!      integer, intent(in) :: unit                                           !
+!      character(len=*), intent(in) :: name                                  !
+!      real, intent(in), optional :: rval(:)                                 !
+!      integer, intent(in), optional :: ival(:)                              !
+!      character(len=*), intent(in), optional :: cval                        !
+!                                                                            !
+!    This form defines global metadata associated with the file as a         !
+!    whole. The attribute is named <name> and can take on a real, integer    !
+!    or character value. <rval> and <ival> can be scalar or 1D arrays.       !
+!                                                                            !
+!  mpp_write_meta( unit, id, name, rval=rval, pack=pack )                    !
+!  mpp_write_meta( unit, id, name, ival=ival )                               !
+!  mpp_write_meta( unit, id, name, cval=cval )                               !
+!      integer, intent(in) :: unit, id                                       !
+!      character(len=*), intent(in) :: name                                  !
+!      real, intent(in), optional :: rval(:)                                 !
+!      integer, intent(in), optional :: ival(:)                              !
+!      character(len=*), intent(in), optional :: cval                        !
+!                                                                            !
+!    This form defines metadata associated with a previously defined         !
+!    axis or field, identified to mpp_write_meta by its unique ID <id>.      !
+!    The attribute is named <name> and can take on a real, integer           !
+!    or character value. <rval> and <ival> can be scalar or 1D arrays.       !
+!    This need not be called for attributes already contained in             !
+!    the type.                                                               !
+!                                                                            !
+!    PACK can take values 1,2,4,8. This only has meaning when writing        !
+!    floating point numbers. The value of PACK defines the number of words   !
+!    written into 8 bytes. For pack=4 and pack=8, an integer value is        !
+!    written: rval is assumed to have been scaled to the appropriate dynamic !
+!    range.                                                                  !
+!    PACK currently only works for netCDF files, and is ignored otherwise.   !
+!                                                                            !
+!   subroutine mpp_write_meta_axis( unit, axis, name, units, longname, &     !
+!        cartesian, sense, domain, data )                                    !
+!     integer, intent(in) :: unit                                            !
+!     type(axistype), intent(inout) :: axis                                  !
+!     character(len=*), intent(in) :: name, units, longname                  !
+!     character(len=*), intent(in), optional :: cartesian                    !
+!     integer, intent(in), optional :: sense                                 !
+!     type(domain1D), intent(in), optional :: domain                 !
+!     real, intent(in), optional :: data(:)                                  !
+!                                                                            !
+!    This form defines a time or space axis. Metadata corresponding to the   !
+!    type above are written to the file on <unit>. A unique ID for subsequent!
+!    references to this axis is returned in axis%id. If the <domain>         !
+!    element is present, this is recognized as a distributed data axis       !
+!    and domain decomposition information is also written if required (the   !
+!    domain decomposition info is required for multi-fileset multi-threaded  !
+!    I/O). If the <data> element is allocated, it is considered to be a space!
+!    axis, otherwise it is a time axis with an unlimited dimension. Only one !
+!    time axis is allowed per file.                                          !
+!                                                                            !
+!   subroutine mpp_write_meta_field( unit, field, axes, name, units, longname!
+!        min, max, missing, fill, scale, add, pack )                         !
+!     integer, intent(in) :: unit                                            !
+!     type(fieldtype), intent(out) :: field                                  !
+!     type(axistype), intent(in) :: axes(:)                                  !
+!     character(len=*), intent(in) :: name, units, longname                  !
+!     real, intent(in), optional :: min, max, missing, fill, scale, add      !
+!     integer, intent(in), optional :: pack                                  !
+!                                                                            !
+!    This form defines a field. Metadata corresponding to the type           !
+!    above are written to the file on <unit>. A unique ID for subsequent     !
+!    references to this field is returned in field%id. At least one axis     !
+!    must be associated, 0D variables are not considered. mpp_write_meta     !
+!    must previously have been called on all axes associated with this       !
+!    field.                                                                  !
+!                                                                            !
+! The mpp_write_meta package also includes subroutines write_attribute and   !
+! write_attribute_netcdf, that are private to this module.                   !
+!                                                                            !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    subroutine mpp_write_meta_global( unit, name, rval, ival, cval, pack )
+!writes a global metadata attribute to unit <unit>
+!attribute <name> can be an real, integer or character
+!one and only one of rval, ival, and cval should be present
+!the first found will be used
+!for a non-netCDF file, it is encoded into a string "GLOBAL <name> <val>"
+      integer, intent(in) :: unit
+      character(len=*), intent(in) :: name
+      real,             intent(in), optional :: rval(:)
+      integer,          intent(in), optional :: ival(:)
+      character(len=*), intent(in), optional :: cval
+      integer, intent(in), optional :: pack
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          call write_attribute_netcdf( unit, NF_GLOBAL, name, rval, ival, cval, pack )
+#endif
+      else
+          call write_attribute( unit, 'GLOBAL '//trim(name), rval, ival, cval, pack )
+      end if
+
+      return
+    end subroutine mpp_write_meta_global
+
+!versions of above to support <rval> and <ival> as scalars (because of f90 strict rank matching)
+    subroutine mpp_write_meta_global_scalar_r( unit, name, rval, pack )
+      integer, intent(in) :: unit
+      character(len=*), intent(in) :: name
+      real, intent(in) :: rval
+      integer, intent(in), optional :: pack
+
+      call mpp_write_meta_global( unit, name, rval=(/rval/), pack=pack )
+      return
+    end subroutine mpp_write_meta_global_scalar_r
+
+    subroutine mpp_write_meta_global_scalar_i( unit, name, ival )
+      integer, intent(in) :: unit
+      character(len=*), intent(in) :: name
+      integer, intent(in) :: ival
+
+      call mpp_write_meta_global( unit, name, ival=(/ival/) )
+      return
+    end subroutine mpp_write_meta_global_scalar_i
+
+    subroutine mpp_write_meta_var( unit, id, name, rval, ival, cval, pack )
+!writes a metadata attribute for variable <id> to unit <unit>
+!attribute <name> can be an real, integer or character
+!one and only one of rval, ival, and cval should be present
+!the first found will be used
+!for a non-netCDF file, it is encoded into a string "<id> <name> <val>"
+      integer, intent(in) :: unit, id
+      character(len=*), intent(in) :: name
+      real,             intent(in), optional :: rval(:)
+      integer,          intent(in), optional :: ival(:)
+      character(len=*), intent(in), optional :: cval
+      integer, intent(in), optional :: pack
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+          call write_attribute_netcdf( unit, id, name, rval, ival, cval, pack )
+      else
+          write( text, '(a,i4,a)' )'VARIABLE ', id, ' '//name
+          call write_attribute( unit, trim(text), rval, ival, cval, pack )
+      end if
+
+      return
+    end subroutine mpp_write_meta_var
+
+!versions of above to support <rval> and <ival> as scalar (because of f90 strict rank matching)
+    subroutine mpp_write_meta_scalar_r( unit, id, name, rval, pack )
+      integer, intent(in) :: unit, id
+      character(len=*), intent(in) :: name
+      real, intent(in) :: rval
+      integer, intent(in), optional :: pack
+
+      call mpp_write_meta( unit, id, name, rval=(/rval/), pack=pack )
+      return
+    end subroutine mpp_write_meta_scalar_r
+
+    subroutine mpp_write_meta_scalar_i( unit, id, name, ival )
+      integer, intent(in) :: unit, id
+      character(len=*), intent(in) :: name
+      integer, intent(in) :: ival
+
+      call mpp_write_meta( unit, id, name, ival=(/ival/) )
+      return
+    end subroutine mpp_write_meta_scalar_i
+
+    subroutine mpp_write_meta_axis( unit, axis, name, units, longname, cartesian, sense, domain, data )
+!load the values in an axistype (still need to call mpp_write)
+!write metadata attributes for axis
+!it is declared intent(inout) so you can nullify pointers in the incoming object if needed
+!the f90 standard doesn't guarantee that intent(out) on a type guarantees that its pointer components will be unassociated
+      integer, intent(in) :: unit
+      type(axistype), intent(inout) :: axis
+      character(len=*), intent(in) :: name, units, longname
+      character(len=*), intent(in), optional :: cartesian
+      integer, intent(in), optional :: sense
+      type(domain1D), intent(in), optional :: domain
+      real, intent(in), optional :: data(:)
+      integer :: is, ie, isg, ieg
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+!pre-existing pointers need to be nullified
+      if( ASSOCIATED(axis%data) )NULLIFY(axis%data)
+!load axistype
+      axis%name     = name
+      axis%units    = units
+      axis%longname = longname
+      if( PRESENT(cartesian) )axis%cartesian = cartesian
+      if( PRESENT(sense)     )axis%sense     = sense
+      if( PRESENT(domain)    )then
+          axis%domain = domain
+          call mpp_get_global_domain( domain, isg, ieg )
+          call mpp_get_compute_domain( domain, is, ie )
+      else
+          axis%domain = NULL_DOMAIN1D
+          if( PRESENT(data) )then
+             isg=1; ieg=size(data); is=isg; ie=ieg
+          endif
+      end if
+      if( PRESENT(data) )then
+          if( PRESENT(domain) )then
+              if( size(data).NE.ieg-isg+1 ) &
+                   call mpp_error( FATAL, 'MPP_WRITE_META_AXIS: size(data).NE.domain%global%size.' )
+              allocate( axis%data(isg:ieg) )
+          else
+              allocate( axis%data(size(data)) )
+          end if
+          axis%data = data
+      end if
+
+!write metadata
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+!write axis def
+!space axes are always floats, time axis is always double
+          if( ASSOCIATED(axis%data) )then !space axis
+              if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+                  error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, ie-is+1,         axis%did )
+              else
+                  error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, size(axis%data), axis%did )
+              end if
+              call netcdf_err(error)
+              error = NF_DEF_VAR( mpp_file(unit)%ncid, axis%name, NF_FLOAT, 1, axis%did, axis%id ); call netcdf_err(error)
+          else                            !time axis
+              if( mpp_file(unit)%id.NE.-1 ) &
+                   call mpp_error( FATAL, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
+              error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, NF_UNLIMITED, axis%did ); call netcdf_err(error)
+              error = NF_DEF_VAR( mpp_file(unit)%ncid, axis%name, NF_DOUBLE, 1, axis%did, axis%id ); call netcdf_err(error)
+              mpp_file(unit)%id = axis%id !file ID is the same as time axis varID
+          end if
+#endif
+      else
+          varnum = varnum + 1
+          axis%id = varnum
+          axis%did = varnum
+!write axis def
+          write( text, '(a,i4,a)' )'AXIS ', axis%id, ' name'
+          call write_attribute( unit, trim(text), cval=axis%name )
+          write( text, '(a,i4,a)' )'AXIS ', axis%id, ' size'
+          if( ASSOCIATED(axis%data) )then !space axis
+              if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+                  call write_attribute( unit, trim(text), ival=(/ie-is+1/) )
+              else
+                  call write_attribute( unit, trim(text), ival=(/size(axis%data)/) )
+              end if
+          else                            !time axis
+              if( mpp_file(unit)%id.NE.-1 ) &
+                   call mpp_error( FATAL, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
+              call write_attribute( unit, trim(text), ival=(/0/) ) !a size of 0 indicates time axis
+              mpp_file(unit)%id = axis%id
+          end if
+      end if
+!write axis attributes
+      call mpp_write_meta( unit, axis%id, 'long_name', cval=axis%longname )
+      call mpp_write_meta( unit, axis%id, 'units',     cval=axis%units    )
+      if( PRESENT(cartesian) )call mpp_write_meta( unit, axis%id, 'cartesian_axis', cval=axis%cartesian )
+      if( PRESENT(sense) )then
+          if( sense.EQ.-1 )then
+              call mpp_write_meta( unit, axis%id, 'positive', cval='down' )
+          else if( sense.EQ.1 )then
+              call mpp_write_meta( unit, axis%id, 'positive', cval='up' )
+          end if
+!silently ignore values of sense other than +/-1.
+      end if
+      if( mpp_file(unit)%threading.EQ.MPP_MULTI .AND. mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+          call mpp_write_meta( unit, axis%id, 'domain_decomposition', ival=(/isg,ieg,is,ie/) )
+      end if
+      if( verbose )print '(a,2i3,x,a,2i3)', 'MPP_WRITE_META: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
+           pe, unit, trim(axis%name), axis%id, axis%did 
+
+      return
+    end subroutine mpp_write_meta_axis
+
+    subroutine mpp_write_meta_field( unit, field, axes, name, units, longname, min, max, missing, fill, scale, add, pack )
+!define field: must have already called mpp_write_meta(axis) for each axis
+      integer, intent(in) :: unit
+      type(fieldtype), intent(out) :: field
+      type(axistype), intent(in) :: axes(:)
+      character(len=*), intent(in) :: name, units, longname
+      real, intent(in), optional :: min, max, missing, fill, scale, add
+      integer, intent(in), optional :: pack
+!this array is required because of f77 binding on netCDF interface
+      integer, allocatable :: axis_id(:)
+      real :: a, b
+      integer :: i
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+!pre-existing pointers need to be nullified
+      if( ASSOCIATED(field%axes) )NULLIFY(field%axes)
+!fill in field metadata
+      field%name = name
+      field%units = units
+      field%longname = longname
+      allocate( field%axes(size(axes)) )
+      field%axes = axes
+      field%time_axis_index = -1 !this value will never match any axis index
+!size is buffer area for the corresponding axis info: it is required to buffer this info in the fieldtype
+!because axis might be reused in different files
+      allocate( field%size(size(axes)) )
+      do i = 1,size(axes)
+         if( ASSOCIATED(axes(i)%data) )then !space axis
+             field%size(i) = size(axes(i)%data)
+         else               !time
+             field%size(i) = 1
+             field%time_axis_index = i
+         end if
+      end do
+!attributes
+      if( PRESENT(min) )field%min = min
+      if( PRESENT(max) )field%max = max
+      if( PRESENT(missing) )field%missing = missing
+      if( PRESENT(fill) )field%fill = fill
+      if( PRESENT(scale) )field%scale = scale
+      if( PRESENT(add) )field%add = add
+      
+!pack is currently used only for netCDF
+      field%pack = 2        !default write 32-bit floats
+      if( PRESENT(pack) )field%pack = pack
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          allocate( axis_id(size(field%axes)) )
+          do i = 1,size(field%axes)
+             axis_id(i) = field%axes(i)%did
+          end do
+!write field def
+          select case (field%pack)
+              case(1)
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_DOUBLE, size(field%axes), axis_id, field%id )
+              case(2)
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_FLOAT,  size(field%axes), axis_id, field%id )
+              case(4)
+                  if( .NOT.PRESENT(scale) .OR. .NOT.PRESENT(add) ) &
+                       call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=4.' )
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_SHORT,  size(field%axes), axis_id, field%id )
+              case(8)
+                  if( .NOT.PRESENT(scale) .OR. .NOT.PRESENT(add) ) &
+                       call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=8.' )
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_BYTE,   size(field%axes), axis_id, field%id )
+              case default
+                  call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
+          end select
+          call netcdf_err(error)
+#endif
+      else
+          varnum = varnum + 1
+          field%id = varnum
+          if( PRESENT(pack) )call mpp_error( WARNING, 'MPP_WRITE_META: Packing is currently available only on netCDF files.' )
+!write field def
+          write( text, '(a,i4,a)' )'FIELD ', field%id, ' name'
+          call write_attribute( unit, trim(text), cval=field%name )
+          write( text, '(a,i4,a)' )'FIELD ', field%id, ' axes'
+          call write_attribute( unit, trim(text), ival=field%axes(:)%did )
+      end if
+!write field attributes: these names follow netCDF conventions
+      call mpp_write_meta( unit, field%id, 'long_name', cval=field%longname )
+      call mpp_write_meta( unit, field%id, 'units',     cval=field%units    )
+!all real attributes must be written as packed
+      if( PRESENT(min) .AND. PRESENT(max) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_range', rval=(/min,max/), pack=pack )
+          else
+              a = nint((min-add)/scale)
+              b = nint((max-add)/scale)
+              call mpp_write_meta( unit, field%id, 'valid_range', rval=(/a,  b  /), pack=pack )
+          end if
+      else if( PRESENT(min) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_min', rval=field%min, pack=pack )
+          else
+              a = nint((min-add)/scale)
+              call mpp_write_meta( unit, field%id, 'valid_min', rval=a, pack=pack )
+          end if
+      else if( PRESENT(max) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_max', rval=field%max, pack=pack )
+          else
+              a = nint((max-add)/scale)
+              call mpp_write_meta( unit, field%id, 'valid_max', rval=a, pack=pack )
+          end if
+      end if
+      if( PRESENT(missing) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'missing_value', rval=field%missing, pack=pack )
+          else
+              a = nint((missing-add)/scale)
+              call mpp_write_meta( unit, field%id, 'missing_value', rval=a, pack=pack )
+          end if
+      end if
+      if( PRESENT(fill) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, '_FillValue', rval=field%missing, pack=pack )
+          else
+              a = nint((fill-add)/scale)
+              call mpp_write_meta( unit, field%id, '_FillValue', rval=a, pack=pack )
+          end if
+      end if
+      if( field%pack.NE.1 .AND. field%pack.NE.2 )then
+          call mpp_write_meta( unit, field%id, 'packing', ival=field%pack )
+          if( PRESENT(scale) )call mpp_write_meta( unit, field%id, 'scale_factor',  rval=field%scale )
+          if( PRESENT(add)   )call mpp_write_meta( unit, field%id, 'add_offset',    rval=field%add   )
+      end if
+      if( verbose )print '(a,2i3,x,a,i3)', 'MPP_WRITE_META: Wrote field metadata: pe, unit, field%name, field%id=', &
+           pe, unit, trim(field%name), field%id 
+
+      return
+    end subroutine mpp_write_meta_field
+
+    subroutine write_attribute( unit, name, rval, ival, cval, pack )
+!called to write metadata for non-netCDF I/O
+      integer, intent(in) :: unit
+      character(len=*), intent(in) :: name
+      real, intent(in), optional :: rval(:)
+      integer, intent(in), optional :: ival(:)
+      character(len=*), intent(in), optional :: cval
+!pack is currently ignored in this routine: only used by netCDF I/O
+      integer, intent(in), optional :: pack
+
+      if( mpp_file(unit)%nohdrs )return
+!encode text string
+      if( PRESENT(rval) )then
+          write( text,* )trim(name)//'=', rval
+      else if( PRESENT(ival) )then
+          write( text,* )trim(name)//'=', ival
+      else if( PRESENT(cval) )then
+          text = ' '//trim(name)//'='//trim(cval)
+      else
+          call mpp_error( FATAL, 'WRITE_ATTRIBUTE: one of rval, ival, cval must be present.' )
+      end if
+      if( mpp_file(unit)%format.EQ.MPP_ASCII )then
+!implies sequential access
+          write( unit,fmt='(a)' )trim(text)//char(10)
+      else                      !MPP_IEEE32 or MPP_NATIVE
+          if( mpp_file(unit)%access.EQ.MPP_SEQUENTIAL )then
+              write(unit)trim(text)//char(10)
+          else                  !MPP_DIRECT
+              write( unit,rec=mpp_file(unit)%record )trim(text)//char(10)
+              if( verbose )print '(a,i3,a,i3)', 'WRITE_ATTRIBUTE: PE=', pe, ' wrote record ', mpp_file(unit)%record
+              mpp_file(unit)%record = mpp_file(unit)%record + 1
+          end if
+      end if
+      return
+    end subroutine write_attribute
+
+    subroutine write_attribute_netcdf( unit, id, name, rval, ival, cval, pack )
+!called to write metadata for netCDF I/O
+      integer, intent(in) :: unit
+      integer, intent(in) :: id
+      character(len=*), intent(in) :: name
+      real,             intent(in), optional :: rval(:)
+      integer,          intent(in), optional :: ival(:)
+      character(len=*), intent(in), optional :: cval
+      integer, intent(in), optional :: pack
+      integer :: lenc
+      integer, allocatable :: rval_i(:)
+#ifdef use_netCDF
+      if( PRESENT(rval) )then
+!pack is only meaningful for FP numbers
+          if( PRESENT(pack) )then
+              if( pack.EQ.1 )then
+                  if( KIND(rval).EQ.DOUBLE_KIND )then
+                      error = NF_PUT_ATT_DOUBLE( mpp_file(unit)%ncid, id, name, NF_DOUBLE, size(rval), rval )
+                  else if( KIND(rval).EQ.FLOAT_KIND )then
+                      call mpp_error( WARNING, &
+                           'WRITE_ATTRIBUTE_NETCDF: attempting to write internal 32-bit real as external 64-bit.' )
+                      error = NF_PUT_ATT_REAL  ( mpp_file(unit)%ncid, id, name, NF_DOUBLE, size(rval), rval )
+                  end if
+                  call netcdf_err(error)
+              else if( pack.EQ.2 )then
+                  if( KIND(rval).EQ.DOUBLE_KIND )then
+                      error = NF_PUT_ATT_DOUBLE( mpp_file(unit)%ncid, id, name, NF_FLOAT,  size(rval), rval )
+                  else if( KIND(rval).EQ.FLOAT_KIND )then
+                      error = NF_PUT_ATT_REAL  ( mpp_file(unit)%ncid, id, name, NF_FLOAT,  size(rval), rval )
+                  end if
+                  call netcdf_err(error)
+              else if( pack.EQ.4 )then
+                  allocate( rval_i(size(rval)) )
+                  rval_i = rval
+                  if( KIND(rval).EQ.DOUBLE_KIND )then
+                      error = NF_PUT_ATT_DOUBLE( mpp_file(unit)%ncid, id, name, NF_SHORT,  size(rval_i), rval )
+                  else if( KIND(rval).EQ.FLOAT_KIND )then
+                      error = NF_PUT_ATT_REAL  ( mpp_file(unit)%ncid, id, name, NF_SHORT,  size(rval_i), rval )
+                  end if
+                  call netcdf_err(error)
+                  deallocate(rval_i)
+              else if( pack.EQ.8 )then
+                  allocate( rval_i(size(rval)) )
+                  rval_i = rval
+                  if( KIND(rval).EQ.DOUBLE_KIND )then
+                      error = NF_PUT_ATT_DOUBLE( mpp_file(unit)%ncid, id, name, NF_BYTE,   size(rval_i), rval )
+                  else if( KIND(rval).EQ.FLOAT_KIND )then
+                      error = NF_PUT_ATT_REAL  ( mpp_file(unit)%ncid, id, name, NF_BYTE,   size(rval_i), rval )
+                  end if
+                  call netcdf_err(error)
+                  deallocate(rval_i)
+              else
+                  call mpp_error( FATAL, 'WRITE_ATTRIBUTE_NETCDF: only legal packing values are 1,2,4,8.' )
+              end if
+          else
+!default is to write FLOATs (32-bit)
+              if( KIND(rval).EQ.DOUBLE_KIND )then
+                  error = NF_PUT_ATT_DOUBLE( mpp_file(unit)%ncid, id, name, NF_FLOAT,  size(rval), rval )
+              else if( KIND(rval).EQ.FLOAT_KIND )then
+                  error = NF_PUT_ATT_REAL  ( mpp_file(unit)%ncid, id, name, NF_FLOAT,  size(rval), rval )
+              end if
+              call netcdf_err(error)
+          end if
+      else if( PRESENT(ival) )then
+          error = NF_PUT_ATT_INT ( mpp_file(unit)%ncid, id, name, NF_INT, size(ival), ival ); call netcdf_err(error)
+      else if( present(cval) )then
+          error = NF_PUT_ATT_TEXT( mpp_file(unit)%ncid, id, name, len_trim(cval), cval ); call netcdf_err(error)
+      else
+          call mpp_error( FATAL, 'WRITE_ATTRIBUTE_NETCDF: one of rval, ival, cval must be present.' )
+      end if
+#endif /* use_netCDF */ 
+      return
+    end subroutine write_attribute_netcdf
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!                             MPP_WRITE                                !
+!                                                                      !
+! mpp_write is used to write data to the file on <unit> using the      !
+! file parameters supplied by mpp_open(). Axis and field definitions   !
+! must have previously been written to the file using mpp_write_meta.  !
+!                                                                      !
+! mpp_write can take 2 forms, one for distributed data and one for     !
+! non-distributed data. Distributed data refer to arrays whose two     !
+! fastest-varying indices are domain-decomposed. Distributed data      !
+! must be 2D or 3D (in space). Non-distributed data can be 0-3D.       !
+!                                                                      !
+! In all calls to mpp_write, tstamp is an optional argument. It is to  !
+! be omitted if the field was defined not to be a function of time.    !
+! Results are unpredictable if the argument is supplied for a time-    !
+! independent field, or omitted for a time-dependent field. Repeated   !
+! writes of a time-independent field are also not recommended. One     !
+! time level of one field is written per call.                         !
+!                                                                      !
+!                                                                      !
+! For non-distributed data, use                                        !
+!                                                                      !
+!  mpp_write( unit, field, data, tstamp )                              !
+!     integer, intent(in) :: unit                                      !
+!     type(fieldtype), intent(in) :: field                             !
+!     real, optional :: tstamp                                         !
+!     data is real and can be scalar or of rank 1-3.                   !
+!                                                                      !
+! For distributed data, use                                            !
+!                                                                      !
+!  mpp_write( unit, field, domain, data, tstamp )                      !
+!     integer, intent(in) :: unit                                      !
+!     type(fieldtype), intent(in) :: field                             !
+!     type(domain2D), intent(in) :: domain                             !
+!     real, optional :: tstamp                                         !
+!     data is real and can be of rank 2 or 3.                          !
+!                                                                      !
+!  mpp_write( unit, axis )                                             !
+!     integer, intent(in) :: unit                                      !
+!     type(axistype), intent(in) :: axis                               !
+!                                                                      !
+! This call writes the actual co-ordinate values along each space      !
+! axis. It must be called once for each space axis after all other     !
+! metadata has been written.                                           !
+!                                                                      !
+! The mpp_write package also includes the routine write_record which   !
+! performs the actual write. This routine is private to this module.   !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#define MPP_WRITE_2DDECOMP_1D_ mpp_write_2ddecomp_r1d
+#define MPP_WRITE_2DDECOMP_2D_ mpp_write_2ddecomp_r2d
+#define MPP_WRITE_2DDECOMP_3D_ mpp_write_2ddecomp_r3d
+#define MPP_TYPE_ real
+#include <mpp_write_2Ddecomp.h>
+
+#define MPP_WRITE_ mpp_write_r0D
+#define MPP_TYPE_ real
+#define MPP_RANK_ !
+#define MPP_WRITE_RECORD_ call write_record( unit, field, 1, (/data/), tstamp )
+#include <mpp_write.h>
+
+#define MPP_WRITE_ mpp_write_r1D
+#define MPP_TYPE_ real
+#define MPP_WRITE_RECORD_ call write_record( unit, field, size(data), data, tstamp )
+#define MPP_RANK_ (:)
+#include <mpp_write.h>
+
+#define MPP_WRITE_ mpp_write_r2D
+#define MPP_TYPE_ real
+#define MPP_WRITE_RECORD_ call write_record( unit, field, size(data), data, tstamp )
+#define MPP_RANK_ (:,:)
+#include <mpp_write.h>
+
+#define MPP_WRITE_ mpp_write_r3D
+#define MPP_TYPE_ real
+#define MPP_WRITE_RECORD_ call write_record( unit, field, size(data), data, tstamp )
+#define MPP_RANK_ (:,:,:)
+#include <mpp_write.h>
+
+#define MPP_WRITE_ mpp_write_r4D
+#define MPP_TYPE_ real
+#define MPP_WRITE_RECORD_ call write_record( unit, field, size(data), data, tstamp )
+#define MPP_RANK_ (:,:,:,:)
+#include <mpp_write.h>
+
+    subroutine mpp_write_axis( unit, axis )
+      integer, intent(in) :: unit
+      type(axistype), intent(in) :: axis
+      type(fieldtype) :: field
+      integer :: is, ie
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_WRITE: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset  .EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+!we convert axis to type(fieldtype) in order to call write_record
+      field = default_field
+      allocate( field%axes(1) )
+      field%axes(1) = axis
+      allocate( field%size(1) )
+      field%id = axis%id
+      if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+          call mpp_get_compute_domain( axis%domain, is, ie )
+          field%size(1) = ie-is+1
+          call write_record( unit, field, field%size(1), axis%data(is:) )
+      else
+          field%size(1) = size(axis%data)
+          call write_record( unit, field, field%size(1), axis%data )
+      end if
+      return
+    end subroutine mpp_write_axis
+
+    subroutine write_record( unit, field, nwords, data, time_in, domain )
+!routine that is finally called by all mpp_write routines to perform the write
+!a non-netCDF record contains:
+!      field ID
+!      a set of 4 coordinates (is:ie,js:je) giving the data subdomain
+!      a timelevel and a timestamp (=NULLTIME if field is static)
+!      3D real data (stored as 1D)
+!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above
+!in a global direct access file, record position on PE is given by %record.
+
+!Treatment of timestamp:
+!   We assume that static fields have been passed without a timestamp.
+!   Here that is converted into a timestamp of NULLTIME.
+!   For non-netCDF fields, field is treated no differently, but is written
+!   with a timestamp of NULLTIME. There is no check in the code to prevent
+!   the user from repeatedly writing a static field.
+
+      integer, intent(in) :: unit, nwords
+      type(fieldtype), intent(in) :: field
+      real, intent(in) :: data(nwords)
+      real(DOUBLE_KIND), intent(in), optional :: time_in
+      type(domain2D), intent(in), optional :: domain
+      integer, dimension(size(field%axes)) :: start, axsiz
+      real :: time
+      integer :: time_level
+      logical :: newtime
+      integer :: subdomain(4)
+      integer :: packed_data(nwords)
+      integer :: i, is, ie, js, je, isg, ieg, jsg, jeg, isizc, jsizc, isizg, jsizg
+
+#ifdef use_CRI_pointers
+      real(FLOAT_KIND) :: data_r4(nwords)
+      pointer( ptr1, data_r4)
+      pointer( ptr2, packed_data)
+
+      if (mpp_io_stack_size < 2*nwords) call mpp_io_set_stack_size(2*nwords)
+
+      ptr1 = LOC(mpp_io_stack(1))
+      ptr2 = LOC(mpp_io_stack(nwords+1))
+#endif
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_WRITE: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset  .EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+
+      if( .NOT.mpp_file(unit)%initialized )then
+!this is the first call to mpp_write
+!we now declare the file to be initialized
+!if this is netCDF we switch file from DEFINE mode to DATA mode
+          if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+!NOFILL is probably required for parallel: any circumstances in which not advisable?
+              error = NF_SET_FILL( mpp_file(unit)%ncid, NF_NOFILL, i ); call netcdf_err(error)
+              if( mpp_file(unit)%action.EQ.MPP_WRONLY )error = NF_ENDDEF(mpp_file(unit)%ncid); call netcdf_err(error)
+#endif
+          else
+              call mpp_write_meta( unit, 'END', cval='metadata' )
+          end if
+          mpp_file(unit)%initialized = .TRUE.
+          if( verbose )print '(a,i3,a)', 'MPP_WRITE: PE=', pe, ' initialized file '//trim(mpp_file(unit)%name)//'.'
+      end if
+
+!initialize time: by default assume NULLTIME
+      time = NULLTIME
+      time_level = -1
+      newtime = .FALSE.
+      if( PRESENT(time_in) )time = time_in
+!increment time level if new time
+      if( time.GT.mpp_file(unit)%time+EPSILON(time) )then !new time
+          mpp_file(unit)%time_level = mpp_file(unit)%time_level + 1
+          mpp_file(unit)%time = time
+          newtime = .TRUE.
+      end if
+      if( verbose )print '(a,2i3,2i5,es13.5)', 'MPP_WRITE: PE, unit, %id, %time_level, %time=',&
+           pe, unit, mpp_file(unit)%id, mpp_file(unit)%time_level, mpp_file(unit)%time
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+!define netCDF data block to be written:
+!  time axis: START = time level
+!             AXSIZ = 1
+!  space axis: if there is no domain info
+!              START = 1
+!              AXSIZ = field%size(axis)
+!          if there IS domain info:
+!              start of domain is compute%start_index for multi-file I/O
+!                                 global%start_index for all other cases
+!              this number must be converted to 1 for NF_PUT_VAR
+!                  (netCDF fortran calls are with reference to 1),
+!          So, START = compute%start_index - <start of domain> + 1
+!              AXSIZ = usually compute%size
+!          However, if compute%start_index-compute%end_index+1.NE.compute%size,
+!              we assume that the call is passing a subdomain.
+!              To pass a subdomain, you must pass a domain2D object that satisfies the following:
+!                  global%start_index must contain the <start of domain> as defined above;
+!                  the data domain and compute domain must refer to the subdomain being passed.
+!              In this case, START = compute%start_index - <start of domain> + 1
+!                            AXSIZ = compute%start_index - compute%end_index + 1
+! NOTE: passing of subdomains will fail for multi-PE single-threaded I/O,
+!       since that attempts to gather all data on PE 0.
+          start = 1
+          do i = 1,size(field%axes)
+             axsiz(i) = field%size(i)
+             if( i.EQ.field%time_axis_index )start(i) = mpp_file(unit)%time_level
+	     start(i) = max(start(i),1) 
+          end do
+          if( PRESENT(domain) )then
+              call mpp_get_compute_domain( domain, is,  ie,  js,  je,  xsize=isizc, ysize=jsizc )
+              call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=isizg, ysize=jsizg )
+              axsiz(1) = isizc
+              axsiz(2) = jsizc
+              if( npes.GT.1 .AND. mpp_file(unit)%fileset.EQ.MPP_SINGLE )then
+                  start(1) = is - isg + 1
+                  start(2) = js - jsg + 1
+              else
+                  if( isizc.NE.ie-is+1 )then
+                      start(1) = is - isg + 1
+                      axsiz(1) = ie - is + 1
+                  end if
+                  if( jsizc.NE.je-js+1 )then
+                      start(2) = js - jsg + 1
+                      axsiz(2) = je - js + 1
+                  end if
+              end if
+          end if
+          if( debug )print '(a,2i3,12i4)', 'WRITE_RECORD: PE, unit, start, axsiz=', pe, unit, start, axsiz
+#ifdef use_netCDF
+!write time information if new time
+          if( newtime )then
+              if( KIND(time).EQ.DOUBLE_KIND )then
+                  error = NF_PUT_VAR1_DOUBLE( mpp_file(unit)%ncid, mpp_file(unit)%id, mpp_file(unit)%time_level, time )
+              else if( KIND(time).EQ.FLOAT_KIND )then
+                  error = NF_PUT_VAR1_REAL  ( mpp_file(unit)%ncid, mpp_file(unit)%id, mpp_file(unit)%time_level, time )
+              end if
+          end if
+          if( field%pack.LE.2 )then
+              if( KIND(data).EQ.DOUBLE_KIND )then
+!                  write(stderr,*)data
+                  error = NF_PUT_VARA_DOUBLE( mpp_file(unit)%ncid, field%id, start, axsiz, data )
+              else if( KIND(data).EQ.FLOAT_KIND )then                                           
+                  error = NF_PUT_VARA_REAL  ( mpp_file(unit)%ncid, field%id, start, axsiz, data )
+              end if
+          else              !convert to integer using scale and add: no error check on packed data representation
+              packed_data = nint((data-field%add)/field%scale)
+              error = NF_PUT_VARA_INT   ( mpp_file(unit)%ncid, field%id, start, axsiz, packed_data )
+          end if
+          call netcdf_err(error)
+#endif
+      else                      !non-netCDF
+!subdomain contains (/is,ie,js,je/)
+          if( PRESENT(domain) )then
+              subdomain(:) = (/ is, ie, js, je /)
+          else
+              subdomain(:) = -1    ! -1 means use global value from axis metadata
+          end if
+          if( mpp_file(unit)%format.EQ.MPP_ASCII )then
+!implies sequential access
+              write( unit,* )field%id, subdomain, time_level, time, data
+          else                      !MPP_IEEE32 or MPP_NATIVE
+              if( mpp_file(unit)%access.EQ.MPP_SEQUENTIAL )then
+#ifdef __sgi
+                  if( mpp_file(unit)%format.EQ.MPP_IEEE32 )then
+                      data_r4 = data !IEEE conversion layer on SGI until assign -N ieee_32 is supported
+                      write(unit)field%id, subdomain, time_level, time, data_r4
+                  else
+                      write(unit)field%id, subdomain, time_level, time, data
+                  end if
+#else
+                  write(unit)field%id, subdomain, time_level, time, data
+#endif
+              else                  !MPP_DIRECT
+#ifdef __sgi
+                  if( mpp_file(unit)%format.EQ.MPP_IEEE32 )then
+                      data_r4 = data !IEEE conversion layer on SGI until assign -N ieee_32 is supported
+                      write( unit, rec=mpp_file(unit)%record )field%id, subdomain, time_level, time, data_r4
+                  else
+                      write( unit, rec=mpp_file(unit)%record )field%id, subdomain, time_level, time, data
+                  end if
+#else
+                  write( unit, rec=mpp_file(unit)%record )field%id, subdomain, time_level, time, data
+#endif
+                  if( debug )print '(a,i3,a,i3)', 'MPP_WRITE: PE=', pe, ' wrote record ', mpp_file(unit)%record
+              end if
+          end if
+      end if
+
+!recompute current record for direct access I/O
+      if( mpp_file(unit)%access.EQ.MPP_DIRECT )then
+          if( mpp_file(unit)%fileset.EQ.MPP_SINGLE )then
+!assumes all PEs participate in I/O: modify later
+              mpp_file(unit)%record = mpp_file(unit)%record + records_per_pe*npes
+          else
+              mpp_file(unit)%record = mpp_file(unit)%record + records_per_pe
+          end if
+      end if
+
+      return
+    end subroutine write_record
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!                          MPP_COPY_META                               !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    subroutine mpp_copy_meta_global( unit, gatt )
+!writes a global metadata attribute to unit <unit>
+!attribute <name> can be an real, integer or character
+!one and only one of rval, ival, and cval should be present
+!the first found will be used
+!for a non-netCDF file, it is encoded into a string "GLOBAL <name> <val>"
+      integer, intent(in) :: unit
+      type(atttype), intent(in) :: gatt
+      integer :: len
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+#ifdef use_netCDF
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+         if( gatt%type.EQ.NF_CHAR )then
+            len = gatt%len
+            call write_attribute_netcdf( unit, NF_GLOBAL, gatt%name, cval=gatt%catt(1:len) )
+         else
+            call write_attribute_netcdf( unit, NF_GLOBAL, gatt%name, rval=gatt%fatt )
+         endif
+      else
+         if( gatt%type.EQ.NF_CHAR )then
+            len=gatt%len
+            call write_attribute( unit, 'GLOBAL '//trim(gatt%name), cval=gatt%catt(1:len) )
+         else
+            call write_attribute( unit, 'GLOBAL '//trim(gatt%name), rval=gatt%fatt )
+         endif
+     end if
+#else
+     call mpp_error( FATAL, 'MPP_READ currently requires use_netCDF option' )
+#endif
+      return
+    end subroutine mpp_copy_meta_global
+
+    subroutine mpp_copy_meta_axis( unit, axis, domain )
+!load the values in an axistype (still need to call mpp_write)
+!write metadata attributes for axis.  axis is declared inout 
+!because the variable and dimension ids are altered
+
+      integer, intent(in) :: unit
+      type(axistype), intent(inout) :: axis
+      type(domain1D), intent(in), optional :: domain
+      character(len=512) :: text
+      integer :: i, len, is, ie, isg, ieg
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+! redefine domain if present
+      if( PRESENT(domain) )then
+          axis%domain = domain
+      else
+          axis%domain = NULL_DOMAIN1D
+      end if
+
+#ifdef use_netCDF      
+!write metadata
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+
+!write axis def
+          if( ASSOCIATED(axis%data) )then !space axis
+              if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+                  call mpp_get_compute_domain( axis%domain, is, ie )
+                  call mpp_get_global_domain( axis%domain, isg, ieg )
+                  error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, ie-is+1, axis%did )
+              else
+                  error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, size(axis%data),          axis%did )
+              end if
+              call netcdf_err(error)
+              error = NF_DEF_VAR( mpp_file(unit)%ncid, axis%name, NF_FLOAT, 1, axis%did, axis%id ); call netcdf_err(error)
+          else                            !time axis
+              error = NF_DEF_DIM( mpp_file(unit)%ncid, axis%name, NF_UNLIMITED, axis%did ); call netcdf_err(error)
+              error = NF_DEF_VAR( mpp_file(unit)%ncid, axis%name, NF_DOUBLE, 1, axis%did, axis%id ); call netcdf_err(error)
+              mpp_file(unit)%id = axis%id !file ID is the same as time axis varID
+              mpp_file(unit)%recdimid = axis%did ! record dimension id
+          end if
+      else
+          varnum = varnum + 1
+          axis%id = varnum
+          axis%did = varnum
+!write axis def
+          write( text, '(a,i4,a)' )'AXIS ', axis%id, ' name'
+          call write_attribute( unit, trim(text), cval=axis%name )
+          write( text, '(a,i4,a)' )'AXIS ', axis%id, ' size'
+          if( ASSOCIATED(axis%data) )then !space axis
+              if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+                  call write_attribute( unit, trim(text), ival=(/ie-is+1/) )
+              else
+                  call write_attribute( unit, trim(text), ival=(/size(axis%data)/) )
+              end if
+          else                            !time axis
+              if( mpp_file(unit)%id.NE.-1 ) &
+                   call mpp_error( FATAL, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
+              call write_attribute( unit, trim(text), ival=(/0/) ) !a size of 0 indicates time axis
+              mpp_file(unit)%id = axis%id
+          end if
+      end if
+!write axis attributes
+
+      do i=1,axis%natt
+         if( axis%Att(i)%name.NE.default_att%name )then
+            if( axis%Att(i)%type.EQ.NF_CHAR )then
+               len = axis%Att(i)%len
+               call mpp_write_meta( unit, axis%id, axis%Att(i)%name, cval=axis%Att(i)%catt(1:len) )
+            else
+               call mpp_write_meta( unit, axis%id, axis%Att(i)%name, rval=axis%Att(i)%fatt)
+            endif
+         endif
+      enddo
+
+      if( mpp_file(unit)%threading.EQ.MPP_MULTI .AND. mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
+          call mpp_write_meta( unit, axis%id, 'domain_decomposition', ival=(/isg,ieg,is,ie/) )
+      end if
+      if( verbose )print '(a,2i3,x,a,2i3)', 'MPP_WRITE_META: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
+           pe, unit, trim(axis%name), axis%id, axis%did 
+#else
+      call mpp_error( FATAL, 'MPP_READ currently requires use_netCDF option' )
+#endif      
+      return
+    end subroutine mpp_copy_meta_axis    
+
+    subroutine mpp_copy_meta_field( unit, field, axes )
+!useful for copying field metadata from a previous call to mpp_read_meta
+!define field: must have already called mpp_write_meta(axis) for each axis
+      integer, intent(in) :: unit
+      type(fieldtype), intent(inout) :: field
+      type(axistype), intent(in), optional :: axes(:)
+!this array is required because of f77 binding on netCDF interface
+      integer, allocatable :: axis_id(:)
+      real :: a, b
+      integer :: i
+
+      if( .NOT.module_is_initialized    )call mpp_error( FATAL, 'MPP_WRITE_META: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE_META: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_SINGLE   .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%action.NE.MPP_WRONLY )return !no writing metadata on APPEND
+      if( mpp_file(unit)%initialized ) &
+           call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
+
+       if( field%pack.NE.1 .AND. field%pack.NE.2 )then
+            if( field%pack.NE.4 .AND. field%pack.NE.8 ) &
+               call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
+      end if
+
+      if (PRESENT(axes)) then
+         deallocate(field%axes)
+         deallocate(field%size)
+         allocate(field%axes(size(axes)))
+         allocate(field%size(size(axes)))
+         field%axes = axes
+         do i=1,size(axes)
+            if (ASSOCIATED(axes(i)%data)) then
+               field%size(i) = size(axes(i)%data)
+            else
+               field%size(i) = 1
+               field%time_axis_index = i
+            endif
+         enddo
+      endif
+         
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          allocate( axis_id(size(field%axes)) )
+          do i = 1,size(field%axes)
+             axis_id(i) = field%axes(i)%did
+          end do
+!write field def
+          select case (field%pack)
+              case(1)
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_DOUBLE, size(field%axes), axis_id, field%id )
+              case(2)
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_FLOAT,  size(field%axes), axis_id, field%id )
+              case(4)
+                  if( field%scale.EQ.default_field%scale .OR. field%add.EQ.default_field%add ) &
+                       call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=4.' )
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_SHORT,  size(field%axes), axis_id, field%id )
+              case(8)
+                  if( field%scale.EQ.default_field%scale .OR. field%add.EQ.default_field%add ) &
+                       call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=8.' )
+                  error = NF_DEF_VAR( mpp_file(unit)%ncid, field%name, NF_BYTE,   size(field%axes), axis_id, field%id )
+              case default
+                  call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
+          end select
+#endif
+      else
+          varnum = varnum + 1
+          field%id = varnum
+          if( field%pack.NE.default_field%pack ) &
+           call mpp_error( WARNING, 'MPP_WRITE_META: Packing is currently available only on netCDF files.' )
+!write field def
+          write( text, '(a,i4,a)' )'FIELD ', field%id, ' name'
+          call write_attribute( unit, trim(text), cval=field%name )
+          write( text, '(a,i4,a)' )'FIELD ', field%id, ' axes'
+          call write_attribute( unit, trim(text), ival=field%axes(:)%did )
+      end if
+!write field attributes: these names follow netCDF conventions
+      call mpp_write_meta( unit, field%id, 'long_name', cval=field%longname )
+      call mpp_write_meta( unit, field%id, 'units',     cval=field%units    )
+!all real attributes must be written as packed
+      if( (field%min.NE.default_field%min) .AND. (field%max.NE.default_field%max) )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_range', rval=(/field%min,field%max/), pack=field%pack )
+          else
+              a = nint((field%min-field%add)/field%scale)
+              b = nint((field%max-field%add)/field%scale)
+              call mpp_write_meta( unit, field%id, 'valid_range', rval=(/a,  b  /), pack=field%pack )
+          end if
+      else if( field%min.NE.default_field%min )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_min', rval=field%min, pack=field%pack )
+          else
+              a = nint((field%min-field%add)/field%scale)
+              call mpp_write_meta( unit, field%id, 'valid_min', rval=a, pack=field%pack )
+          end if
+      else if( field%max.NE.default_field%max )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'valid_max', rval=field%max, pack=field%pack )
+          else
+              a = nint((field%max-field%add)/field%scale)
+              call mpp_write_meta( unit, field%id, 'valid_max', rval=a, pack=field%pack )
+          end if
+      end if
+      if( field%missing.NE.default_field%missing )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, 'missing_value', rval=field%missing, pack=field%pack )
+          else
+              a = nint((field%missing-field%add)/field%scale)
+              call mpp_write_meta( unit, field%id, 'missing_value', rval=a, pack=field%pack )
+          end if
+      end if
+      if( field%fill.NE.default_field%fill )then
+          if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
+              call mpp_write_meta( unit, field%id, '_FillValue', rval=field%missing, pack=field%pack )
+          else
+              a = nint((field%fill-field%add)/field%scale)
+              call mpp_write_meta( unit, field%id, '_FillValue', rval=a, pack=field%pack )
+          end if
+      end if
+      if( field%pack.NE.1 .AND. field%pack.NE.2 )then
+          call mpp_write_meta( unit, field%id, 'packing', ival=field%pack )
+          if( field%scale.NE.default_field%scale )call mpp_write_meta( unit, field%id, 'scale_factor',  rval=field%scale )
+          if( field%add.NE.default_field%add   )call mpp_write_meta( unit, field%id, 'add_offset',    rval=field%add   )
+      end if
+      if( verbose )print '(a,2i3,x,a,i3)', 'MPP_WRITE_META: Wrote field metadata: pe, unit, field%name, field%id=', &
+           pe, unit, trim(field%name), field%id 
+
+      return
+    end subroutine mpp_copy_meta_field
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!                               MPP_READ                               !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_READ_2DDECOMP_1D_ mpp_read_2ddecomp_r1d
+#define MPP_READ_2DDECOMP_2D_ mpp_read_2ddecomp_r2d
+#define MPP_READ_2DDECOMP_3D_ mpp_read_2ddecomp_r3d
+#define MPP_TYPE_ real
+#include <mpp_read_2Ddecomp.h>
+
+    subroutine read_record( unit, field, nwords, data, time_level, domain )
+!routine that is finally called by all mpp_read routines to perform the read
+!a non-netCDF record contains:
+!      field ID
+!      a set of 4 coordinates (is:ie,js:je) giving the data subdomain
+!      a timelevel and a timestamp (=NULLTIME if field is static)
+!      3D real data (stored as 1D)
+!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above
+!in a global direct access file, record position on PE is given by %record.
+
+!Treatment of timestamp:
+!   We assume that static fields have been passed without a timestamp.
+!   Here that is converted into a timestamp of NULLTIME.
+!   For non-netCDF fields, field is treated no differently, but is written
+!   with a timestamp of NULLTIME. There is no check in the code to prevent
+!   the user from repeatedly writing a static field.
+
+      integer, intent(in) :: unit, nwords
+      type(fieldtype), intent(in) :: field
+      real, intent(inout) :: data(nwords)
+      integer, intent(in), optional  :: time_level
+      type(domain2D), intent(in), optional :: domain
+      integer, dimension(size(field%axes)) :: start, axsiz
+      real :: time
+
+      logical :: newtime
+      integer :: subdomain(4), tlevel
+
+      integer(SHORT_KIND) :: i2vals(nwords)
+!#ifdef __sgi      
+      integer(INT_KIND) :: ivals(nwords)
+      real(FLOAT_KIND) :: rvals(nwords)
+!#else      
+!      integer :: ivals(nwords)
+!      real :: rvals(nwords)      
+!#endif      
+
+      real(DOUBLE_KIND) :: r8vals(nwords)
+
+      integer :: i, error, is, ie, js, je, isg, ieg, jsg, jeg
+
+#ifdef use_CRI_pointers
+      pointer( ptr1, i2vals )
+      pointer( ptr2, ivals )
+      pointer( ptr3, rvals )
+      pointer( ptr4, r8vals )
+
+      if (mpp_io_stack_size < 4*nwords) call mpp_io_set_stack_size(4*nwords)
+
+      ptr1 = LOC(mpp_io_stack(1))
+      ptr2 = LOC(mpp_io_stack(nwords+1))
+      ptr3 = LOC(mpp_io_stack(2*nwords+1))
+      ptr4 = LOC(mpp_io_stack(3*nwords+1))
+#endif
+      if (.not.PRESENT(time_level)) then
+          tlevel = 0
+      else
+          tlevel = time_level
+      endif
+      
+#ifdef use_netCDF
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'READ_RECORD: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'READ_RECORD: invalid unit number.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+      if( mpp_file(unit)%fileset.EQ.MPP_MULTI )call mpp_error( FATAL, 'READ_RECORD: multiple filesets not supported for MPP_READ' )
+
+      if( .NOT.mpp_file(unit)%initialized ) call mpp_error( FATAL, 'MPP_READ: must first call mpp_read_meta.' )
+
+
+ 
+      if( verbose )print '(a,2i3,2i5)', 'MPP_READ: PE, unit, %id, %time_level =',&
+           pe, unit, mpp_file(unit)%id, tlevel
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+!define netCDF data block to be read:
+!  time axis: START = time level
+!             AXSIZ = 1
+!  space axis: if there is no domain info
+!              START = 1
+!              AXSIZ = field%size(axis)
+!          if there IS domain info:
+!              start of domain is compute%start_index for multi-file I/O
+!                                 global%start_index for all other cases
+!              this number must be converted to 1 for NF_GET_VAR
+!                  (netCDF fortran calls are with reference to 1),
+!          So, START = compute%start_index - <start of domain> + 1
+!              AXSIZ = usually compute%size
+!          However, if compute%start_index-compute%end_index+1.NE.compute%size,
+!              we assume that the call is passing a subdomain.
+!              To pass a subdomain, you must pass a domain2D object that satisfies the following:
+!                  global%start_index must contain the <start of domain> as defined above;
+!                  the data domain and compute domain must refer to the subdomain being passed.
+!              In this case, START = compute%start_index - <start of domain> + 1
+!                            AXSIZ = compute%start_index - compute%end_index + 1
+! NOTE: passing of subdomains will fail for multi-PE single-threaded I/O,
+!       since that attempts to gather all data on PE 0.
+          start = 1
+          do i = 1,size(field%axes)
+             axsiz(i) = field%size(i)
+             if( field%axes(i)%did.EQ.field%time_axis_index )start(i) = tlevel
+          end do
+          if( PRESENT(domain) )then
+              call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
+              call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg )
+              axsiz(1) = ie-is+1
+              axsiz(2) = je-js+1
+              if( npes.GT.1 .AND. mpp_file(unit)%fileset.EQ.MPP_SINGLE )then
+                  start(1) = is - isg + 1
+                  start(2) = js - jsg + 1
+              else
+                  if( ie-is+1.NE.ie-is+1 )then
+                      start(1) = is - isg + 1
+                      axsiz(1) = ie - is + 1
+                  end if
+                  if( je-js+1.NE.je-js+1 )then
+                      start(2) = js - jsg + 1
+                      axsiz(2) = je - js + 1
+                  end if
+              end if
+          end if
+
+          if( verbose )print '(a,2i3,i6,12i4)', 'READ_RECORD: PE, unit, nwords, start, axsiz=', pe, unit, nwords, start, axsiz
+
+          select case (field%type)
+             case(NF_BYTE)
+! use type conversion 
+                call mpp_error( FATAL, 'MPP_READ: does not support NF_BYTE packing' )
+             case(NF_SHORT)
+                error = NF_GET_VARA_INT2  ( mpp_file(unit)%ncid, field%id, start, axsiz, i2vals ); call netcdf_err(error)
+                 data(:)=i2vals(:)*field%scale + field%add
+             case(NF_INT)
+                error = NF_GET_VARA_INT   ( mpp_file(unit)%ncid, field%id, start, axsiz, ivals  ); call netcdf_err(error)
+                data(:)=ivals(:)
+             case(NF_FLOAT)
+                error = NF_GET_VARA_REAL  ( mpp_file(unit)%ncid, field%id, start, axsiz, rvals  ); call netcdf_err(error)
+                data(:)=rvals(:)
+             case(NF_DOUBLE)
+                error = NF_GET_VARA_DOUBLE( mpp_file(unit)%ncid, field%id, start, axsiz, r8vals ); call netcdf_err(error)
+                data(:)=r8vals(:)
+             case default
+                call mpp_error( FATAL, 'MPP_READ: invalid pack value' )
+          end select
+      else                      !non-netCDF
+!subdomain contains (/is,ie,js,je/)
+          call mpp_error( FATAL, 'Currently dont support non-NetCDF mpp read' )
+
+      end if
+#else
+      call mpp_error( FATAL, 'MPP_READ currently requires use_netCDF option' )
+#endif      
+      return
+    end subroutine read_record
+
+    subroutine mpp_read_r3D( unit, field, data, tindex)
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      real, intent(inout) :: data(:,:,:)
+      integer, intent(in), optional :: tindex
+
+      call read_record( unit, field, size(data), data, tindex )
+    end subroutine mpp_read_r3D
+
+    subroutine mpp_read_r2D( unit, field, data, tindex )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      real, intent(inout) :: data(:,:)
+      integer, intent(in), optional :: tindex
+
+      call read_record( unit, field, size(data), data, tindex )
+    end subroutine mpp_read_r2D
+
+    subroutine mpp_read_r1D( unit, field, data, tindex )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      real, intent(inout) :: data(:)
+      integer, intent(in), optional :: tindex
+
+      call read_record( unit, field, size(data), data, tindex )
+    end subroutine mpp_read_r1D
+
+    subroutine mpp_read_r0D( unit, field, data, tindex )
+      integer, intent(in) :: unit
+      type(fieldtype), intent(in) :: field
+      real, intent(inout) :: data
+      integer, intent(in), optional :: tindex
+      real, dimension(1) :: data_tmp
+
+      data_tmp(1)=data
+      call read_record( unit, field, 1, data_tmp, tindex )
+      data=data_tmp(1)
+    end subroutine mpp_read_r0D
+
+    subroutine mpp_read_meta(unit)
+!
+! read file attributes including dimension and variable attributes
+! and store in filetype structure.  All of the file information
+! with the exception of the (variable) data is stored.  Attributes
+! are supplied to the user by get_info,get_atts,get_axes and get_fields  
+!
+! every PE is eligible to call mpp_read_meta
+!
+      integer, parameter :: MAX_DIMVALS = 100000
+      integer, intent(in) :: unit
+
+      integer         :: ncid,ndim,nvar_total,natt,recdim,nv,nvar,len
+      integer :: error,i,j 
+      integer         :: type,nvdims,nvatts, dimid
+      integer, allocatable, dimension(:) :: dimids
+      type(axistype) , allocatable, dimension(:) :: Axis
+      character(len=128) :: name, attname, unlimname, attval
+      logical :: isdim
+
+      integer(SHORT_KIND) :: i2vals(MAX_DIMVALS)
+!#ifdef __sgi
+      integer(INT_KIND) :: ivals(MAX_DIMVALS)
+      real(FLOAT_KIND)  :: rvals(MAX_DIMVALS)
+!#else      
+!      integer :: ivals(MAX_DIMVALS)
+!      real    :: rvals(MAX_DIMVALS)      
+!#endif      
+      real(DOUBLE_KIND) :: r8vals(MAX_DIMVALS)
+
+#ifdef use_netCDF      
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+        ncid = mpp_file(unit)%ncid
+        error = NF_INQ(ncid,ndim, nvar_total,&
+                      natt, recdim);call netcdf_err(error)
+
+
+        mpp_file(unit)%ndim = ndim
+        mpp_file(unit)%natt = natt
+        mpp_file(unit)%recdimid = recdim
+!
+! if no recdim exists, recdimid = -1
+! variable id of unlimdim and length
+!
+        if( recdim.NE.-1 )then 
+           error = NF_INQ_DIM( ncid, recdim, unlimname, mpp_file(unit)%time_level );call netcdf_err(error)
+           error = NF_INQ_VARID( ncid, unlimname, mpp_file(unit)%id ); call netcdf_err(error)
+        else
+           mpp_file(unit)%time_level = -1 ! set to zero so mpp_get_info returns ntime=0 if no time axis present
+        endif
+
+        allocate(mpp_file(unit)%Att(natt))
+        allocate(Axis(ndim))
+        allocate(dimids(ndim))
+        allocate(mpp_file(unit)%Axis(ndim))          
+
+!
+! initialize fieldtype and axis type
+!
+
+
+        do i=1,ndim
+           Axis(i) = default_axis
+           mpp_file(unit)%Axis(i) = default_axis
+        enddo
+
+        do i=1,natt
+           mpp_file(unit)%Att(i) = default_att
+        enddo
+        
+!
+! assign global attributes
+!
+        do i=1,natt
+           error=NF_INQ_ATTNAME(ncid,NF_GLOBAL,i,name);call netcdf_err(error)
+           error=NF_INQ_ATT(ncid,NF_GLOBAL,trim(name),type,len);call netcdf_err(error)
+           mpp_file(unit)%Att(i)%name = name
+           mpp_file(unit)%Att(i)%len = len
+           mpp_file(unit)%Att(i)%type = type
+!
+!  allocate space for att data and assign 
+!
+           select case (type)
+              case (NF_CHAR)
+                 if (len.gt.512) then
+		    call mpp_error(NOTE,'GLOBAL ATT too long - not reading this metadata') 
+                    len=7
+                    mpp_file(unit)%Att(i)%len=len
+                    mpp_file(unit)%Att(i)%catt = 'unknown'
+                 else
+                     error=NF_GET_ATT_TEXT(ncid,NF_GLOBAL,name,mpp_file(unit)%Att(i)%catt);call netcdf_err(error)
+                     if (verbose.and.pe == 0) print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%catt(1:len)
+                 endif
+!
+! store integers in float arrays
+!
+              case (NF_SHORT)
+                 allocate(mpp_file(unit)%Att(i)%fatt(len))
+                 error=NF_GET_ATT_INT2(ncid,NF_GLOBAL,name,i2vals);call netcdf_err(error)
+                 if( verbose .and. pe == 0 )print *, 'GLOBAL ATT ',trim(name),' ',i2vals(1:len)
+                 mpp_file(unit)%Att(i)%fatt(1:len)=i2vals(1:len)
+              case (NF_INT)
+                 allocate(mpp_file(unit)%Att(i)%fatt(len))
+                 error=NF_GET_ATT_INT(ncid,NF_GLOBAL,name,ivals);call netcdf_err(error)
+                 if( verbose .and. pe == 0 )print *, 'GLOBAL ATT ',trim(name),' ',ivals(1:len)
+                 mpp_file(unit)%Att(i)%fatt(1:len)=ivals(1:len)
+              case (NF_FLOAT)
+                 allocate(mpp_file(unit)%Att(i)%fatt(len))
+                 error=NF_GET_ATT_REAL(ncid,NF_GLOBAL,name,rvals);call netcdf_err(error)
+                 mpp_file(unit)%Att(i)%fatt(1:len)=rvals(1:len)
+                 if( verbose .and. pe == 0)print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%fatt(1:len)
+              case (NF_DOUBLE)
+                 allocate(mpp_file(unit)%Att(i)%fatt(len))
+                 error=NF_GET_ATT_DOUBLE(ncid,NF_GLOBAL,name,r8vals);call netcdf_err(error)
+                 mpp_file(unit)%Att(i)%fatt(1:len)=r8vals(1:len)
+                 if( verbose .and. pe == 0)print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%fatt(1:len)
+           end select
+
+        enddo
+!
+! assign dimension name and length
+!
+        do i=1,ndim
+           error = NF_INQ_DIM(ncid,i,name,len);call netcdf_err(error)
+           Axis(i)%name = name
+           Axis(i)%len = len
+        enddo
+
+        nvar=0
+        do i=1, nvar_total
+           error=NF_INQ_VAR(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err(error)
+           isdim=.false.
+           do j=1,ndim
+              if( trim(lowercase(name)).EQ.trim(lowercase(Axis(j)%name)) )isdim=.true.
+           enddo
+           if (.not.isdim) nvar=nvar+1
+        enddo
+        mpp_file(unit)%nvar = nvar
+        allocate(mpp_file(unit)%Var(nvar))
+
+        do i=1,nvar
+           mpp_file(unit)%Var(i) = default_field
+        enddo
+        
+!
+! assign dimension info
+!
+        do i=1, nvar_total
+           error=NF_INQ_VAR(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err(error)
+           isdim=.false.
+           do j=1,ndim
+              if( trim(lowercase(name)).EQ.trim(lowercase(Axis(j)%name)) )isdim=.true.
+           enddo
+
+           if( isdim )then
+              error=NF_INQ_DIMID(ncid,name,dimid);call netcdf_err(error)
+              Axis(dimid)%type = type
+              Axis(dimid)%did = dimid
+              Axis(dimid)%id = i
+              Axis(dimid)%natt = nvatts
+              ! get axis values
+              if( i.NE.mpp_file(unit)%id )then   ! non-record dims
+                 select case (type)
+                 case (NF_INT)
+                    len=Axis(dimid)%len
+                    allocate(Axis(dimid)%data(len))
+                    error = NF_GET_VAR_INT(ncid,i,ivals);call netcdf_err(error)
+                    Axis(dimid)%data(1:len)=ivals(1:len)                     
+                 case (NF_FLOAT)
+                    len=Axis(dimid)%len
+                    allocate(Axis(dimid)%data(len))
+                    error = NF_GET_VAR_REAL(ncid,i,rvals);call netcdf_err(error)
+                    Axis(dimid)%data(1:len)=rvals(1:len)
+                 case (NF_DOUBLE)
+                    len=Axis(dimid)%len
+                    allocate(Axis(dimid)%data(len))
+                    error = NF_GET_VAR_DOUBLE(ncid,i,r8vals);call netcdf_err(error)
+                    Axis(dimid)%data(1:len) = r8vals(1:len)
+                 case default
+                    call mpp_error( FATAL, 'Invalid data type for dimension' )
+                 end select
+             else
+                 len = mpp_file(unit)%time_level
+                 allocate(mpp_file(unit)%time_values(len))
+                 select case (type)
+                 case (NF_FLOAT)
+                    error = NF_GET_VAR_REAL(ncid,i,rvals);call netcdf_err(error)
+                    mpp_file(unit)%time_values(1:len) = rvals(1:len)
+                 case (NF_DOUBLE)
+                    error = NF_GET_VAR_DOUBLE(ncid,i,r8vals);call netcdf_err(error)
+                    mpp_file(unit)%time_values(1:len) = r8vals(1:len)
+                 case default
+                    call mpp_error( FATAL, 'Invalid data type for dimension' )
+                 end select
+              endif
+              ! assign dimension atts
+              if( nvatts.GT.0 )allocate(Axis(dimid)%Att(nvatts))
+
+              do j=1,nvatts
+                 Axis(dimid)%Att(j) = default_att
+              enddo
+
+              do j=1,nvatts
+                 error=NF_INQ_ATTNAME(ncid,i,j,attname);call netcdf_err(error)
+                 error=NF_INQ_ATT(ncid,i,trim(attname),type,len);call netcdf_err(error)
+
+                 Axis(dimid)%Att(j)%name = trim(attname)
+                 Axis(dimid)%Att(j)%type = type
+                 Axis(dimid)%Att(j)%len = len
+
+                 select case (type)
+                 case (NF_CHAR)
+                    if (len.gt.512) call mpp_error(FATAL,'DIM ATT too long') 
+                    error=NF_GET_ATT_TEXT(ncid,i,trim(attname),Axis(dimid)%Att(j)%catt);call netcdf_err(error)
+                    if( verbose .and. pe == 0 ) &
+                         print *, 'AXIS ',trim(Axis(dimid)%name),' ATT ',trim(attname),' ',Axis(dimid)%Att(j)%catt(1:len)
+                    ! store integers in float arrays
+                    ! assume dimension data not packed 
+                 case (NF_SHORT)
+                    allocate(Axis(dimid)%Att(j)%fatt(len))
+                    error=NF_GET_ATT_INT2(ncid,i,trim(attname),i2vals);call netcdf_err(error)
+                    Axis(dimid)%Att(j)%fatt(1:len)=i2vals(1:len)
+                    if( verbose .and. pe == 0  ) &
+                         print *, 'AXIS ',trim(Axis(dimid)%name),' ATT ',trim(attname),' ',Axis(dimid)%Att(j)%fatt
+                 case (NF_INT)
+                    allocate(Axis(dimid)%Att(j)%fatt(len))
+                    error=NF_GET_ATT_INT(ncid,i,trim(attname),ivals);call netcdf_err(error)
+                    Axis(dimid)%Att(j)%fatt(1:len)=ivals(1:len)
+                    if( verbose .and. pe == 0  ) &
+                         print *, 'AXIS ',trim(Axis(dimid)%name),' ATT ',trim(attname),' ',Axis(dimid)%Att(j)%fatt
+                 case (NF_FLOAT)
+                    allocate(Axis(dimid)%Att(j)%fatt(len))
+                    error=NF_GET_ATT_REAL(ncid,i,trim(attname),rvals);call netcdf_err(error)
+                    Axis(dimid)%Att(j)%fatt(1:len)=rvals(1:len)
+                    if( verbose  .and. pe == 0 ) &
+                         print *, 'AXIS ',trim(Axis(dimid)%name),' ATT ',trim(attname),' ',Axis(dimid)%Att(j)%fatt
+                 case (NF_DOUBLE)
+                    allocate(Axis(dimid)%Att(j)%fatt(len))
+                    error=NF_GET_ATT_DOUBLE(ncid,i,trim(attname),r8vals);call netcdf_err(error)
+                    Axis(dimid)%Att(j)%fatt(1:len)=r8vals(1:len)
+                    if( verbose  .and. pe == 0 ) &
+                         print *, 'AXIS ',trim(Axis(dimid)%name),' ATT ',trim(attname),' ',Axis(dimid)%Att(j)%fatt
+                 case default
+                    call mpp_error( FATAL, 'Invalid data type for dimension at' )                      
+                 end select
+                 ! assign pre-defined axis attributes
+                 select case(trim(attname))
+                 case('long_name')
+                    Axis(dimid)%longname=Axis(dimid)%Att(j)%catt(1:len)
+                 case('units')
+                    Axis(dimid)%units=Axis(dimid)%Att(j)%catt(1:len)
+                 case('cartesian_axis')
+                    Axis(dimid)%cartesian=Axis(dimid)%Att(j)%catt(1:len)
+                 case('positive') 
+                    attval = Axis(dimid)%Att(j)%catt(1:len)
+                    if( attval.eq.'down' )then
+                       Axis(dimid)%sense=-1
+                    else if( attval.eq.'up' )then
+                       Axis(dimid)%sense=1
+                    endif
+                 end select
+
+              enddo
+              ! store axis info in filetype
+              mpp_file(unit)%Axis(dimid) = Axis(dimid)
+           endif
+        enddo
+! assign variable info
+        nv = 0
+        do i=1, nvar_total
+           error=NF_INQ_VAR(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err(error)
+!
+! is this a dimension variable?
+!          
+           isdim=.false.
+           do j=1,ndim
+              if( trim(lowercase(name)).EQ.trim(lowercase(Axis(j)%name)) )isdim=.true.
+           enddo
+
+           if( .not.isdim )then
+! for non-dimension variables
+              nv=nv+1; if( nv.GT.mpp_file(unit)%nvar )call mpp_error( FATAL, 'variable index exceeds number of defined variables' )
+              mpp_file(unit)%Var(nv)%type = type
+              mpp_file(unit)%Var(nv)%id = i
+              mpp_file(unit)%Var(nv)%name = name
+              mpp_file(unit)%Var(nv)%natt = nvatts
+! determine packing attribute based on NetCDF variable type
+             select case (type)
+             case(NF_SHORT)
+                 mpp_file(unit)%Var(nv)%pack = 4
+             case(NF_FLOAT)
+                 mpp_file(unit)%Var(nv)%pack = 2
+             case(NF_DOUBLE)
+                 mpp_file(unit)%Var(nv)%pack = 1
+             case (NF_INT)
+                 mpp_file(unit)%Var(nv)%pack = 2
+             case default
+                   call mpp_error( FATAL, 'Invalid variable type in NetCDF file' )
+             end select
+! assign dimension ids
+              mpp_file(unit)%Var(nv)%ndim = nvdims
+              allocate(mpp_file(unit)%Var(nv)%axes(nvdims))
+              do j=1,nvdims
+                 mpp_file(unit)%Var(nv)%axes(j) = Axis(dimids(j))
+              enddo
+              allocate(mpp_file(unit)%Var(nv)%size(nvdims))
+
+              do j=1,nvdims
+                 if( dimids(j).eq.mpp_file(unit)%recdimid )then
+                    mpp_file(unit)%Var(nv)%time_axis_index = dimids(j)
+                    mpp_file(unit)%Var(nv)%size(j)=1    ! dimid length set to 1 here for consistency w/ mpp_write 
+                 else
+                    mpp_file(unit)%Var(nv)%size(j)=Axis(dimids(j))%len
+                 endif
+              enddo
+! assign variable atts
+              if( nvatts.GT.0 )allocate(mpp_file(unit)%Var(nv)%Att(nvatts))
+
+              do j=1,nvatts
+                 mpp_file(unit)%Var(nv)%Att(j) = default_att
+              enddo
+              
+              do j=1,nvatts
+                 error=NF_INQ_ATTNAME(ncid,i,j,attname);call netcdf_err(error)
+                 error=NF_INQ_ATT(ncid,i,attname,type,len);call netcdf_err(error)
+                 mpp_file(unit)%Var(nv)%Att(j)%name = trim(attname)
+                 mpp_file(unit)%Var(nv)%Att(j)%type = type
+                 mpp_file(unit)%Var(nv)%Att(j)%len = len
+                 
+                 select case (type)
+                   case (NF_CHAR)
+                     if (len.gt.512) call mpp_error(FATAL,'VAR ATT too long') 
+                     error=NF_GET_ATT_TEXT(ncid,i,trim(attname),mpp_file(unit)%Var(nv)%Att(j)%catt(1:len));call netcdf_err(error)
+                     if (verbose .and. pe == 0 )&
+                           print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
+! store integers as float internally
+                   case (NF_SHORT)
+                     allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len))
+                     error=NF_GET_ATT_INT2(ncid,i,trim(attname),i2vals);call netcdf_err(error)
+                     mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)= i2vals(1:len)
+                     if( verbose  .and. pe == 0 )&
+                          print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
+                   case (NF_INT)
+                     allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len))
+                     error=NF_GET_ATT_INT(ncid,i,trim(attname),ivals);call netcdf_err(error)
+                     mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=ivals(1:len)
+                     if( verbose .and. pe == 0  )&
+                          print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
+                   case (NF_FLOAT)
+                     allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len))
+                     error=NF_GET_ATT_REAL(ncid,i,trim(attname),rvals);call netcdf_err(error)
+                     mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=rvals(1:len)
+                     if( verbose  .and. pe == 0 )&
+                          print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
+                   case (NF_DOUBLE)
+                     allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len))
+                     error=NF_GET_ATT_DOUBLE(ncid,i,trim(attname),r8vals);call netcdf_err(error)
+                     mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=r8vals(1:len)
+                     if( verbose .and. pe == 0  ) &
+                          print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
+                   case default
+                        call mpp_error( FATAL, 'Invalid data type for variable att' )
+                 end select
+! assign pre-defined field attributes
+                 select case (trim(attname))
+                    case ('long_name')
+                      mpp_file(unit)%Var(nv)%longname=mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
+                    case('units')
+                      mpp_file(unit)%Var(nv)%units=mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
+                    case('scale_factor') 
+                       mpp_file(unit)%Var(nv)%scale=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
+                    case('missing') 
+                       mpp_file(unit)%Var(nv)%missing=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
+                    case('add_offset') 
+                       mpp_file(unit)%Var(nv)%add=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)              
+                    case('valid_range') 
+                       mpp_file(unit)%Var(nv)%min=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
+                       mpp_file(unit)%Var(nv)%max=mpp_file(unit)%Var(nv)%Att(j)%fatt(2)
+                 end select
+              enddo
+           endif
+        enddo   ! end variable loop
+      else
+        call mpp_error( FATAL,  'MPP READ CURRENTLY DOES NOT SUPPORT NON-NETCDF' ) 
+      endif
+
+      mpp_file(unit)%initialized = .TRUE.
+#else
+      call mpp_error( FATAL, 'MPP_READ currently requires use_netCDF option' )
+#endif      
+      return
+    end subroutine mpp_read_meta
+
+
+    subroutine mpp_get_info( unit, ndim, nvar, natt, ntime )
+
+      integer, intent(in) :: unit
+      integer, intent(out) :: ndim, nvar, natt, ntime
+
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_INFO: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_INFO: invalid unit number.' )
+
+      ndim = mpp_file(unit)%ndim
+      nvar = mpp_file(unit)%nvar
+      natt = mpp_file(unit)%natt
+      ntime = mpp_file(unit)%time_level
+
+      return
+
+    end subroutine mpp_get_info
+
+     
+    subroutine mpp_get_global_atts( unit, global_atts )
+!
+!  copy global file attributes for use by user
+!
+!  global_atts is an attribute type which is allocated from the
+!  calling routine
+
+      integer,       intent(in)    :: unit
+      type(atttype), intent(inout) :: global_atts(:)
+      integer :: natt,i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_INFO: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_INFO: invalid unit number.' )
+
+      if (size(global_atts).lt.mpp_file(unit)%natt) &
+      call mpp_error(FATAL, 'MPP_GET_ATTS: atttype not dimensioned properly in calling routine')
+
+      natt = mpp_file(unit)%natt
+      global_atts = default_att
+
+      do i=1,natt
+         global_atts(i) = mpp_file(unit)%Att(i)
+      enddo
+
+      return
+   end subroutine mpp_get_global_atts
+
+   subroutine mpp_get_field_atts( field, name, units, longname, min, max, missing, ndim, siz, axes, atts )
+
+     type(fieldtype), intent(in) :: field
+     character(len=*), intent(out) , optional :: name, units
+     character(len=*), intent(out), optional :: longname
+     real,intent(out), optional :: min,max,missing
+     integer, intent(out), optional :: ndim
+     integer, intent(out), dimension(:), optional :: siz
+
+     type(atttype), intent(out), optional, dimension(:) :: atts
+     type(axistype), intent(out), optional, dimension(:) :: axes
+
+     integer :: n,m
+
+     if (PRESENT(name)) name = field%name
+     if (PRESENT(units)) units = field%units
+     if (PRESENT(longname)) longname = field%longname
+     if (PRESENT(min)) min = field%min
+     if (PRESENT(max)) max = field%max
+     if (PRESENT(missing)) missing = field%missing
+     if (PRESENT(ndim)) ndim = field%ndim
+     if (PRESENT(atts)) then
+        atts = default_att
+        n = size(atts);m=size(field%Att)
+        if (n.LT.m) call mpp_error(FATAL,'attribute array not large enough in mpp_get_field_atts')
+        atts(1:m) = field%Att(1:m)
+     end if
+     if (PRESENT(axes)) then
+        axes = default_axis
+        n = size(axes);m=field%ndim
+        if (n.LT.m) call mpp_error(FATAL,'axis array not large enough in mpp_get_field_atts')
+        axes(1:m) = field%axes(1:m)
+     end if
+     if (PRESENT(siz)) then
+        siz = -1
+        n = size(siz);m=field%ndim
+        if (n.LT.m) call mpp_error(FATAL,'size array not large enough in mpp_get_field_atts')
+        siz(1:m) = field%size(1:m)
+     end if     
+     return
+   end subroutine mpp_get_field_atts
+
+   subroutine mpp_get_axis_atts( axis, name, units, longname, cartesian, sense, len, natts, atts )
+
+     type(axistype), intent(in) :: axis
+     character(len=*), intent(out) , optional :: name, units
+     character(len=*), intent(out), optional :: longname, cartesian
+     integer,intent(out), optional :: sense, len , natts
+     type(atttype), intent(out), optional, dimension(:) :: atts
+
+     integer :: n,m 
+
+     if (PRESENT(name)) name = axis%name
+     if (PRESENT(units)) units = axis%units
+     if (PRESENT(longname)) longname = axis%longname
+     if (PRESENT(cartesian)) cartesian = axis%cartesian
+     if (PRESENT(sense)) sense = axis%sense
+     if (PRESENT(len)) len = axis%len
+     if (PRESENT(atts)) then
+        atts = default_att
+        n = size(atts);m=size(axis%Att)
+        if (n.LT.m) call mpp_error(FATAL,'attribute array not large enough in mpp_get_field_atts')
+        atts(1:m) = axis%Att(1:m)
+     end if
+     if (PRESENT(natts)) natts = size(axis%Att)
+     
+     return
+   end subroutine mpp_get_axis_atts
+
+
+    subroutine mpp_get_fields( unit, variables )
+!
+!  copy variable information from file (excluding data)
+!  global_atts is an attribute type which is allocated from the
+!  calling routine
+! 
+      integer,         intent(in)    :: unit
+      type(fieldtype), intent(inout) :: variables(:)
+
+      integer :: nvar,i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_FIELDS: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_FIELDS: invalid unit number.' )
+
+      if (size(variables).ne.mpp_file(unit)%nvar) &
+      call mpp_error(FATAL, 'MPP_GET_FIELDS: fieldtype not dimensioned properly in calling routine')
+
+      nvar = mpp_file(unit)%nvar
+
+      do i=1,nvar
+         variables(i) = mpp_file(unit)%Var(i)
+      enddo
+
+      return
+   end subroutine mpp_get_fields
+
+    subroutine mpp_get_axes( unit, axes, time_axis )
+!
+!  copy variable information from file (excluding data)
+!  global_atts is an attribute type which is allocated from the
+!  calling routine
+! 
+      integer, intent(in) :: unit
+      type(axistype), intent(out) :: axes(:)
+      type(axistype), intent(out), optional :: time_axis      
+      character(len=128) :: name
+      logical :: save
+      integer :: ndim,i, nvar, j, num_dims, k
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_AXES: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_AXES: invalid unit number.' )
+
+      if (size(axes).ne.mpp_file(unit)%ndim) &
+      call mpp_error(FATAL, 'MPP_GET_AXES: axistype not dimensioned properly in calling routine')
+
+      
+      if (PRESENT(time_axis)) time_axis = default_axis
+      ndim = mpp_file(unit)%ndim
+      do i=1,ndim
+        if (ASSOCIATED(mpp_file(unit)%Axis(i)%data)) then   
+           axes(i)=mpp_file(unit)%Axis(i)
+       else
+           axes(i)=mpp_file(unit)%Axis(i)
+           if (PRESENT(time_axis)) time_axis = mpp_file(unit)%Axis(i)
+        endif
+      enddo
+
+      return
+   end subroutine mpp_get_axes
+
+   subroutine mpp_get_times( unit, time_values )
+!
+!  copy time information from file and convert to time_type
+! 
+      integer, intent(in) :: unit
+      real(DOUBLE_KIND), intent(inout) :: time_values(:)
+
+      integer :: ntime,i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_TIMES: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_TIMES: invalid unit number.' )
+
+      if (size(time_values).ne.mpp_file(unit)%time_level) &
+      call mpp_error(FATAL, 'MPP_GET_TIMES: time_values not dimensioned properly in calling routine')
+
+      ntime = mpp_file(unit)%time_level
+
+      do i=1,ntime
+         time_values(i) = mpp_file(unit)%time_values(i)
+      enddo
+
+
+
+      return
+   end subroutine mpp_get_times
+
+   function mpp_get_field_index(fields,fieldname)
+
+     type(fieldtype), dimension(:) :: fields
+     character(len=*) :: fieldname
+     integer :: mpp_get_field_index
+
+     integer :: n
+
+     mpp_get_field_index = -1
+
+     do n=1,size(fields)
+        if (lowercase(fields(n)%name) == lowercase(fieldname)) then
+           mpp_get_field_index = n
+           exit
+        endif
+     enddo
+
+     return
+   end function mpp_get_field_index
+
+   function mpp_get_field_size(field)
+
+     type(fieldtype) :: field
+     integer :: mpp_get_field_size(4)
+
+     integer :: n
+
+     mpp_get_field_size = -1
+
+     mpp_get_field_size(1) = field%size(1)
+     mpp_get_field_size(2) = field%size(2)
+     mpp_get_field_size(3) = field%size(3)
+     mpp_get_field_size(4) = field%size(4)
+
+     return
+   end function mpp_get_field_size
+
+
+   subroutine mpp_get_axis_data( axis, data )
+
+     type(axistype), intent(in) :: axis
+     real, dimension(:), intent(out) :: data
+
+
+     if (size(data).lt.axis%len) call mpp_error(FATAL,'MPP_GET_AXIS_DATA: data array not large enough')
+     if (.NOT.ASSOCIATED(axis%data)) then
+        call mpp_error(NOTE,'MPP_GET_AXIS_DATA: use mpp_get_times for record dims')
+        data = 0.
+     else
+        data(1:axis%len) = axis%data
+     endif
+
+     return
+   end subroutine mpp_get_axis_data
+
+
+   function mpp_get_recdimid(unit)
+!
+      integer, intent(in) :: unit
+      integer  :: mpp_get_recdimid
+
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_RECDIMID: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_RECDIMID: invalid unit number.' )
+
+      mpp_get_recdimid = mpp_file(unit)%recdimid
+
+      return
+   end function mpp_get_recdimid
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!         mpp_get_iospec, mpp_flush: OS-dependent calls                !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_flush(unit)
+!flush the output on a unit, syncing with disk
+      integer, intent(in) :: unit
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_FLUSH: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_FLUSH: invalid unit number.' )
+      if( .NOT.mpp_file(unit)%initialized )call mpp_error( FATAL, 'MPP_FLUSH: cannot flush a file during writing of metadata.' )
+      if( mpp_file(unit)%threading.EQ.MPP_SINGLE .AND. pe.NE.mpp_root_pe() )return
+
+      if( mpp_file(unit)%format.EQ.MPP_NETCDF )then
+#ifdef use_netCDF
+          error = NF_SYNC(mpp_file(unit)%ncid); call netcdf_err(error)
+#endif
+      else
+          call FLUSH(unit)
+      end if
+      return
+    end subroutine mpp_flush
+
+    subroutine mpp_get_iospec( unit, iospec )
+      integer, intent(in) :: unit
+      character(len=*), intent(out) :: iospec
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GET_IOSPEC: must first call mpp_io_init.' )
+      if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_GET_IOSPEC: invalid unit number.' )
+#ifdef SGICRAY
+!currently will write to stdout: don't know how to trap and return as string to iospec
+      call ASSIGN( 'assign -V f:'//trim(mpp_file(unit)%name), error )
+#endif
+      return
+    end subroutine mpp_get_iospec
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!         netCDF-specific routines: mpp_get_id, netcdf_error         !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    function mpp_get_ncid(unit)
+      integer :: mpp_get_ncid
+      integer, intent(in) :: unit
+
+      mpp_get_ncid = mpp_file(unit)%ncid
+      return
+    end function mpp_get_ncid
+
+    function mpp_get_axis_id(axis)
+      integer mpp_get_axis_id
+      type(axistype), intent(in) :: axis
+      mpp_get_axis_id = axis%id
+      return
+    end function mpp_get_axis_id
+
+    function mpp_get_field_id(field)
+      integer mpp_get_field_id
+      type(fieldtype), intent(in) :: field
+      mpp_get_field_id = field%id
+      return
+    end function mpp_get_field_id
+
+    subroutine netcdf_err(err)
+      integer, intent(in) :: err
+      character(len=80) :: errmsg
+      integer :: unit
+
+#ifdef use_netCDF
+      if( err.EQ.NF_NOERR )return
+      errmsg = NF_STRERROR(err)
+      call mpp_io_exit()        !make sure you close all open files
+      call mpp_error( FATAL, 'NETCDF ERROR: '//trim(errmsg) )
+#endif
+      return
+    end subroutine netcdf_err
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                      !
+!       minor routines: mpp_get_unit_range, mpp_set_unit_range         !
+!                                                                      !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_get_unit_range( unit_begin_out, unit_end_out )
+      integer, intent(out) ::      unit_begin_out, unit_end_out
+
+      unit_begin_out = unit_begin; unit_end_out = unit_end
+      return
+    end subroutine mpp_get_unit_range
+
+    subroutine mpp_set_unit_range( unit_begin_in, unit_end_in )
+      integer, intent(in) ::       unit_begin_in, unit_end_in
+
+      if( unit_begin_in.GT.unit_end_in )call mpp_error( FATAL, 'MPP_SET_UNIT_RANGE: unit_begin_in.GT.unit_end_in.' )
+      if( unit_begin_in.LT.0           )call mpp_error( FATAL, 'MPP_SET_UNIT_RANGE: unit_begin_in.LT.0.' )
+      if( unit_end_in  .GT.maxunits    )call mpp_error( FATAL, 'MPP_SET_UNIT_RANGE: unit_end_in.GT.maxunits.' )
+      unit_begin = unit_begin_in; unit_end = unit_end_in
+      return
+    end subroutine mpp_set_unit_range
+
+    subroutine mpp_modify_axis_meta( axis, name, units, longname, cartesian, data )
+
+      type(axistype), intent(inout) :: axis
+      character(len=*), intent(in), optional :: name, units, longname, cartesian
+      real, dimension(:), intent(in), optional :: data
+
+      if (PRESENT(name)) axis%name = trim(name)
+      if (PRESENT(units)) axis%units = trim(units)
+      if (PRESENT(longname)) axis%longname = trim(longname)
+      if (PRESENT(cartesian)) axis%cartesian = trim(cartesian)
+      if (PRESENT(data)) then
+         axis%len = size(data)
+         if (ASSOCIATED(axis%data)) deallocate(axis%data)
+         allocate(axis%data(axis%len))
+         axis%data = data
+      endif
+         
+      return
+    end subroutine mpp_modify_axis_meta
+
+    subroutine mpp_modify_field_meta( field, name, units, longname, min, max, missing, axes )
+
+      type(fieldtype), intent(inout) :: field
+      character(len=*), intent(in), optional :: name, units, longname
+      real, intent(in), optional :: min, max, missing
+      type(axistype), dimension(:), intent(inout), optional :: axes
+
+      if (PRESENT(name)) field%name = trim(name)
+      if (PRESENT(units)) field%units = trim(units)
+      if (PRESENT(longname)) field%longname = trim(longname)
+      if (PRESENT(min)) field%min = min
+      if (PRESENT(max)) field%max = max
+      if (PRESENT(missing)) field%missing = missing
+!      if (PRESENT(axes)) then
+!         axis%len = size(data)
+!         deallocate(axis%data)
+!         allocate(axis%data(axis%len))
+!         axis%data = data
+!      endif
+         
+      return
+    end subroutine mpp_modify_field_meta
+
+    function lowercase (cs) 
+      character(len=*), intent(in) :: cs
+      character(len=len(cs))       :: lowercase 
+      character :: ca(len(cs)) 
+      
+      integer, parameter :: co=iachar('a')-iachar('A') ! case offset
+      
+      ca = transfer(cs,"x",len(cs)) 
+      where (ca >= "A" .and. ca <= "Z") ca = achar(iachar(ca)+co) 
+          lowercase = transfer(ca,cs) 
+          
+    end function lowercase
+        
+end module mpp_io_mod
+
+#ifdef test_mpp_io
+program mpp_io_test
+
+  use mpp_mod
+  use mpp_domains_mod
+  use mpp_io_mod
+
+  implicit none
+#include <mpif.h>
+
+#ifdef use_netCDF
+#include <netcdf.inc>
+#endif
+
+  integer :: pe, npes
+  type(domain2D) :: domain
+  integer :: nx=240, ny=240, nz=40, nt=2, halo=2, stackmax=32768, stackmaxd=32768
+  real, dimension(:,:,:), allocatable :: data, gdata, rdata
+  real, dimension(:,:), allocatable :: lat,lon
+  integer :: is, ie, js, je, isd, ied, jsd, jed
+  integer :: tk, tk0, tks_per_sec
+  integer :: i,j,k, unit=7, layout(2)
+  logical :: debug=.FALSE., opened
+  character(len=64) :: file='test', iospec='-F cachea', varname
+  namelist / mpp_io_nml / nx, ny, nz, nt, halo, stackmax, stackmaxd, debug, file, iospec
+  integer :: ndim, nvar, natt, ntime
+  type(atttype), allocatable :: atts(:)
+  type(fieldtype), allocatable :: vars(:)
+  type(axistype), allocatable :: axes(:)
+  real(DOUBLE_KIND), allocatable :: tstamp(:)
+  real(DOUBLE_KIND) :: time
+  real :: dt,bytes,bw
+  type(axistype) :: x, y, z, t
+  type(fieldtype) :: f,latij,lonij
+  type(domain1D) :: xdom, ydom
+  integer(LONG_KIND) :: rchk, chk
+
+  call mpi_init(is)
+  call mpp_init(mpp_comm=MPI_COMM_WORLD)
+  pe = mpp_pe()
+  npes = mpp_npes()
+
+!possibly open a file called mpp_io.nml
+  do
+     inquire( unit=unit, opened=opened )
+     if( .NOT.opened )exit
+     unit = unit + 1
+     if( unit.EQ.100 )call mpp_error( FATAL, 'Unable to locate unit number.' )
+  end do
+  open( unit=unit, status='OLD', file='mpp_io.nml', err=10 )
+  read( unit,mpp_io_nml )
+  close(unit)
+10 continue
+
+  call SYSTEM_CLOCK( count_rate=tks_per_sec )
+  if( debug )then
+      call mpp_io_init(MPP_DEBUG)
+  else
+      call mpp_io_init()
+  end if
+  call mpp_set_stack_size(stackmax)
+  call mpp_domains_set_stack_size(stackmaxd)
+
+  if( pe.EQ.mpp_root_pe() )then
+      print '(a,6i4)', 'npes, nx, ny, nz, nt, halo=', npes, nx, ny, nz, nt, halo
+      print *, 'Using NEW domaintypes and calls...'
+  end if
+!define global data array
+  allocate( gdata(nx,ny,nz) )
+  if( pe.EQ.mpp_root_pe() )then
+!      call random_number(gdata) )
+!fill in global array: with k.iiijjj
+      gdata = 0.
+      do k = 1,nz
+         do j = 1,ny
+            do i = 1,nx
+               gdata(i,j,k) = k + i*1e-3 + j*1e-6
+            end do
+         end do
+      end do
+  end if
+  call mpp_broadcast( gdata, size(gdata), mpp_root_pe() )
+
+!define domain decomposition
+  call mpp_define_layout( (/1,nx,1,ny/), npes, layout )
+  call mpp_define_domains( (/1,nx,1,ny/), layout, domain, xhalo=halo, yhalo=halo )
+  call mpp_get_compute_domain( domain, is,  ie,  js,  je  )
+  call mpp_get_data_domain   ( domain, isd, ied, jsd, jed )
+  call mpp_get_domain_components( domain, xdom, ydom )
+  allocate( data(isd:ied,jsd:jed,nz) )
+  data(is:ie,js:je,:) = gdata(is:ie,js:je,:)
+
+  allocate( lat(isd:ied,jsd:jed) )
+  allocate( lon(isd:ied,jsd:jed) )
+  do j=js,je
+  do i=is,ie
+    lat(i,j)=i+j
+    lon(i,j)=-(i+j)
+  enddo
+  enddo
+
+!tests
+  write( file,'(a,i3.3)' )trim(file), npes
+
+
+!netCDF distributed write
+  if( pe.EQ.mpp_root_pe() )print *, 'netCDF distributed write'
+  call mpp_open( unit, trim(file)//'d', action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_MULTI )
+  call mpp_write_meta( unit, x,'X','km','x-coordinate in Cartesian system',&
+                     domain=xdom, data=(/(i-1.,i=1,nx)/) )
+  call mpp_write_meta( unit, y,'Y','km','x-coordinate in Cartesian system',&
+                     domain=ydom, data=(/(i-1.,i=1,ny)/) )
+
+  call mpp_write_meta( unit, z,'Z','km','height in Cartesian system ',&
+                     sense=1,data=(/(i-1.,i=1,nz)/) )
+!  The optional parameter sense=1  has the same meaning of writing
+!  call mpp_write_meta( unit, z%id, 'positive', cval='up')
+
+  call mpp_write_meta( unit, t, 'time', 'sec', 'Time' )
+
+  call mpp_write_meta( unit, latij, (/x,y/), 'lat', 'degrees_north', &
+ 'latitude')
+  call mpp_write_meta( unit, lonij, (/x,y/), 'lon', 'degrees_east', &
+ 'longitude')
+
+  call mpp_write_meta( unit, f, (/x,y,z,t/), 'T', 'K', 'Temperature', pack=1 )
+  call mpp_write_meta( unit, mpp_get_id(f), 'coordinates',cval='lon lat')
+  call mpp_write( unit, x )
+  call mpp_write( unit, y )
+  call mpp_write( unit, z )
+  call mpp_write( unit, latij, domain, lat)
+  call mpp_write( unit, lonij, domain, lon)
+  call system_clock(tk0)
+  do i = 0,nt-1
+     time = i*10.
+     call mpp_write( unit, f, domain, data, time )
+  end do
+  call mpp_close(unit)
+  call system_clock(tk)
+  dt = real(tk-tk0)/(tks_per_sec)
+  dt = max( dt, epsilon(dt) )
+  bytes=(ie-is+1)*(je-js+1)*nz*npes*nt*kind(data)
+  bw=bytes*1.e-6/dt
+  if( pe.EQ.mpp_root_pe() ) &
+  write(stdout(),'(a,g12.5,a,g12.5,a,g12.5,a)')'MPP_WRITE multi: n = ',&
+  bytes,' bytes  time =',dt,' s  bw = ',bw,' MByte/s'
+  
+!netCDF single-threaded write
+  if( pe.EQ.mpp_root_pe() )print *, 'netCDF single-threaded write'
+  call mpp_open( unit, trim(file)//'s', action=MPP_OVERWR, form=MPP_NETCDF, threading=MPP_SINGLE )
+!  call mpp_write_meta( unit, x, 'X', 'km', 'X distance', domain=xdom, data=(/(i-1.,i=1,nx)/) )
+!  call mpp_write_meta( unit, y, 'Y', 'km', 'Y distance', domain=ydom, data=(/(i-1.,i=1,ny)/) )
+!  call mpp_write_meta( unit, z, 'Z', 'km', 'Z distance',              data=(/(i-1.,i=1,nz)/) )
+!  call mpp_write_meta( unit, t, 'T', 'sec', 'Time' )
+!  call mpp_write_meta( unit, f, (/x,y,z,t/), 'Data', 'metres', 'Random data', pack=1 )
+!  call mpp_write( unit, x )
+!  call mpp_write( unit, y )
+!  call mpp_write( unit, z )
+  call mpp_write_meta( unit, x,'X','km','x-coordinate in Cartesian system',&
+                     domain=xdom, data=(/(i-1.,i=1,nx)/) )
+  call mpp_write_meta( unit, y,'Y','km','x-coordinate in Cartesian system',&
+                     domain=ydom, data=(/(i-1.,i=1,ny)/) )
+
+  call mpp_write_meta( unit, z,'Z','km','height in Cartesian system ',&
+                     sense=1,data=(/(i-1.,i=1,nz)/) )
+
+!  The optional parameter sense=1  has the same meaning as writing
+!  call mpp_write_meta( unit, z%id, 'positive', cval='up')
+
+  call mpp_write_meta( unit, t, 'time', 'sec', 'Time' )
+
+  call mpp_write_meta( unit, latij, (/x,y/), 'lat', 'degrees_north', &
+ 'latitude')
+  call mpp_write_meta( unit, lonij, (/x,y/), 'lon', 'degrees_east', &
+ 'longitude')
+
+  call mpp_write_meta( unit, f, (/x,y,z,t/), 'T', 'K', 'Temperature', pack=1 )
+  call mpp_write_meta( unit, mpp_get_id(f), 'coordinates',cval='lon lat')
+  call mpp_write( unit, x )
+  call mpp_write( unit, y )
+  call mpp_write( unit, z )
+  call mpp_write( unit, latij, domain, lat)
+  call mpp_write( unit, lonij, domain, lon)
+
+  call system_clock(tk0)
+  do i = 0,nt-1
+     time = i*10.
+     call mpp_write( unit, f, domain, data, time )
+  end do
+  call mpp_close(unit)
+  call system_clock(tk)
+  dt = real(tk-tk0)/(tks_per_sec)
+  dt = max( dt, epsilon(dt) )
+  bytes=(ie-is+1)*(je-js+1)*nz*npes*nt*kind(data)
+  bw=bytes*1.e-6/dt
+  if( pe.EQ.mpp_root_pe() ) &
+  write(stdout(),'(a,g12.5,a,g12.5,a,g12.5,a)')'MPP_WRITE single: n = ',&
+  bytes,' bytes  time =',dt,' s  bw = ',bw,' MByte/s'
+
+!netCDF multi-threaded read
+  if( pe.EQ.mpp_root_pe() )print *, 'netCDF multi-threaded read'
+  call mpp_sync()               !wait for previous write to complete
+  call mpp_open( unit, trim(file)//'s', action=MPP_RDONLY, form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE )
+  call mpp_get_info( unit, ndim, nvar, natt, ntime )
+  allocate( atts(natt) )
+  allocate( axes(ndim) )
+  allocate( vars(nvar) )
+  allocate( tstamp(ntime) )
+  call mpp_get_atts ( unit, atts(:) )
+  call mpp_get_axes ( unit, axes(:) )
+  call mpp_get_fields ( unit, vars(:) )
+  call mpp_get_times( unit, tstamp(:) )
+
+  k=-1
+  do i=1,nvar
+  call mpp_get_atts(vars(i),name=varname)
+  write(stdout(),*) varname
+  if(varname.eq.'T')k=i
+  enddo
+
+!  if( varname.NE.'Data' )call mpp_error( FATAL, 'File being read is not the expected one.' )
+  if( k.lt.0 )call mpp_error( FATAL, 'File being read is not the expected one.' )
+  allocate( rdata(is:ie,js:je,nz) )
+  call system_clock(tk0)
+  call mpp_read( unit, vars(k), domain, rdata, 1 )
+  call system_clock(tk)
+  dt = real(tk-tk0)/(tks_per_sec)
+  dt = max( dt, epsilon(dt) )
+  bytes=(ie-is+1)*(je-js+1)*nz*npes*kind(data)
+  bw=bytes*1.e-6/dt
+  if( pe.EQ.mpp_root_pe() ) &
+  write(stdout(),'(a,g12.5,a,g12.5,a,g12.5,a)')'MPP_READ multi: n = ',&
+  bytes,' bytes  time =',dt,' s  bw = ',bw,' MByte/s'
+  rchk = mpp_chksum(rdata(is:ie,js:je,:))
+  chk  = mpp_chksum( data(is:ie,js:je,:))
+  if( pe.EQ.mpp_root_pe() )print '(a,2z18)', 'checksum=', rchk, chk
+  if( rchk.NE.chk )call mpp_error( FATAL, 'Checksum error on multi-threaded netCDF read.' )
+
+  call mpp_io_exit()
+  call mpp_domains_exit()
+  call mpp_exit()
+  call mpi_finalize(is)
+
+end program mpp_io_test
+
+#endif
Index: CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_mod.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_mod.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/src/mpp_mod.F90	(revision 1677)
@@ -0,0 +1,2667 @@
+!-----------------------------------------------------------------------
+!                 Communication for message-passing codes
+!
+! AUTHOR: V. Balaji (vbalaji@noaa.gov)
+!         Princeton University/GFDL
+!
+! MODIFICATIONS: Reiner Vogelsang (reiner@sgi.com)
+!
+! This program is free software; The author agrees that you can
+! redistribute and/or modify this version of the program under the
+! terms of the Lesser GNU General Public License as published
+! by the Free Software Foundation.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! Lesser GNU General Public License for more details
+! (http://www.gnu.org/copyleft/lesser.html).
+!-----------------------------------------------------------------------
+
+!these are used to determine hardware/OS/compiler
+!#include <os.h>
+
+!onlysgi_mipspro one of SMA or MPI can be used
+!(though mixing calls is allowed, this module will not)
+#ifdef use_libSMA
+#undef use_libMPI
+#endif
+!
+#if defined(_CRAYT3E) || defined(_CRAYT3D) || defined(sgi_mipspro)
+#define SGICRAY_MPP
+#endif
+!
+!shmalloc is used on MPP SGI/Cray systems for shmem
+#if defined(use_libSMA) && defined(SGICRAY_MPP)
+#define use_shmalloc
+#endif
+
+module mpp_mod
+use mod_kinds_model
+#include <os.h>
+!string BWA is used to tag lines that are bug workarounds and will disappear
+!when offending compiler bug is fixed
+!a generalized communication package for use with shmem and MPI
+!will add: co_array_fortran, MPI2
+!Balaji (vb@gfdl.gov) 11 May 1998
+#ifdef sgi_mipspro
+#ifdef use_libSMA
+  use shmem_interface
+#endif
+!#ifdef use_libMPI
+!  use mpi
+!#endif
+#endif
+  implicit none
+  private
+  character(len=128), private :: version= &
+       '$Id: mpp_mod.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $'
+  character(len=128), private :: tagname= &
+       '$Name: ipslcm5a $'
+
+!various lengths (see shpalloc) are estimated in "words" which are 32bit on SGI, 64bit on Cray
+!these are also the expected sizeof of args to MPI/shmem libraries
+#ifdef _CRAY
+  integer(LONG_KIND), private :: word(1)
+#endif
+#ifdef sgi_mipspro
+  integer(INT_KIND), private :: word(1)
+#endif
+
+#ifdef SGICRAY
+!see intro_io(3F): to see why these values are used rather than 5,6,0
+  integer, private :: in_unit=100, out_unit=101, err_unit=102
+#else
+  integer, private :: in_unit=5, out_unit=6, err_unit=0
+#endif
+  integer :: log_unit, etc_unit
+  logical, private :: module_is_initialized=.FALSE.
+  integer, private :: pe=0, node=0, npes=1, root_pe=0
+  integer, private :: error
+  integer, parameter, private :: MAXPES=2048 !used for dimensioning stuff that might be indexed by pe
+  character(len=32) :: configfile='logfile.out'
+  character(len=32) :: etcfile='._mpp.nonrootpe.stdout'
+  logical,save::logfile_defined=.false.,opened
+  integer::io_num
+
+!initialization flags
+  integer, parameter, public :: MPP_VERBOSE=1, MPP_DEBUG=2
+  logical, private :: verbose=.FALSE., debug=.FALSE.
+
+!flags to transmit routines
+  integer, parameter, public :: ALL_PES=-1, ANY_PE=-2, NULL_PE=-3
+
+!errortype flags
+  integer, parameter, public :: NOTE=0, WARNING=1, FATAL=2
+  logical, private :: warnings_are_fatal = .FALSE.
+  integer, private :: error_state=0
+
+  integer(LONG_KIND), parameter, private :: MPP_WAIT=-1, MPP_READY=-2
+#ifdef use_libSMA
+#include <mpp/shmem.fh>
+  integer :: sync(SHMEM_REDUCE_SYNC_SIZE+SHMEM_BCAST_SYNC_SIZE+SHMEM_BARRIER_SYNC_SIZE)
+!status and remote_data_loc are used to synchronize communication is MPP_TRANSMIT
+#ifdef use_shmalloc
+  integer(LONG_KIND), private, dimension(0:MAXPES) :: status, remote_data_loc
+#else
+  integer(LONG_KIND), private, allocatable, dimension(:) :: status, remote_data_loc
+#endif
+  integer, private :: mpp_from_pe !used to announce from where data is coming from
+#ifdef use_shmalloc
+!we call shpalloc in mpp_init() to ensure all these are remotely accessible
+!on PVP where shpalloc doesn't exist, module variables are automatically
+!guaranteed to be remotely accessible
+  pointer( ptr_sync, sync )
+  pointer( ptr_status, status )
+  pointer( ptr_from, mpp_from_pe )
+  pointer( ptr_remote, remote_data_loc )
+#endif
+#endif /* use_libSMA */
+#ifdef use_libMPI
+!#ifndef sgi_mipspro
+!sgi_mipspro gets this from 'use mpi'
+#include <mpif.h>
+!#endif
+!tag is never used, but must be initialized to non-negative integer
+  integer, private :: tag=1, stat(MPI_STATUS_SIZE)
+!  integer, private, allocatable :: request(:)
+  integer, public, allocatable :: request(:)
+#ifdef _CRAYT3E
+!BWA: mpif.h on t3e currently does not contain MPI_INTEGER8 datatype
+!(O2k and t90 do)
+!(t3e: fixed on 3.3 I believe)
+  integer, parameter :: MPI_INTEGER8=MPI_INTEGER
+#endif
+#endif /* use_libMPI */
+
+!mpp_stack is used by SHMEM collective ops
+!must be SHPALLOC'd on SGICRAY_MPP, but is allocatable on PVP
+#ifdef use_shmalloc
+  real(DOUBLE_KIND), private :: mpp_stack(1)
+  pointer( ptr_stack, mpp_stack )
+#else
+  real(DOUBLE_KIND), private, allocatable :: mpp_stack(:)
+#endif
+  integer, private :: mpp_stack_size=0, mpp_stack_hwm=0
+
+!peset hold communicators as SHMEM-compatible triads (start, log2(stride), num)
+  type, private :: communicator
+     character(len=32) :: name
+     integer, pointer :: list(:)
+     integer :: count
+#ifdef use_libSMA
+     integer :: start, log2stride
+#elif use_libMPI
+     integer :: id, group    !MPI communicator and group id for this PE set
+#endif
+  end type
+  integer, parameter :: PESET_MAX=32 !should be .LE. max num of MPI communicators
+  type(communicator) :: peset(0:PESET_MAX) !0 is a dummy used to hold single-PE "self" communicator
+  integer :: peset_num=0, current_peset_num=0
+  integer :: world_peset_num !the world communicator
+
+!performance profiling
+!  This profiles every type of MPI/SHMEM call within
+!    a specified region of high-level code
+!  Initialize or retrieve a clock with
+!  id = mpp_clock_id( 'Region identifier name' )
+!  Then set caliper points around the region using:
+!  call mpp_clock_begin(id)
+!  ...
+!  call mpp_clock_end(id)
+!  mpp_exit will print out the results.
+#ifdef __sgi
+#define SYSTEM_CLOCK system_clock_sgi
+#endif
+
+#ifdef use_libMPI
+#define SYSTEM_CLOCK system_clock_mpi
+#endif
+
+#if defined(__sgi) || defined(use_libMPI)
+  integer(LONG_KIND), private :: tick, ticks_per_sec, max_ticks, start_tick, end_tick, tick0=0
+#else
+  integer, private :: tick, ticks_per_sec, max_ticks, start_tick, end_tick, tick0=0
+#endif
+  real, private :: tick_rate
+  integer, private, parameter :: MAX_CLOCKS=100, MAX_EVENT_TYPES=5, MAX_EVENTS=40000
+!event types
+  integer, private, parameter :: EVENT_ALLREDUCE=1, EVENT_BROADCAST=2, EVENT_RECV=3, EVENT_SEND=4, EVENT_WAIT=5
+  integer, private :: clock_num=0, current_clock=0
+  integer, private :: clock0    !measures total runtime from mpp_init to mpp_exit
+  integer, private :: clock_grain=HUGE(1)
+!the event contains information for each type of event (e.g SHMEM_PUT)
+  type, private :: event
+     character(len=16)  :: name
+     integer(LONG_KIND) :: ticks(MAX_EVENTS), bytes(MAX_EVENTS)
+     integer            :: calls
+  end type event
+!a clock contains an array of event profiles for a region
+  integer, parameter, public :: MPP_CLOCK_SYNC=1, MPP_CLOCK_DETAILED=2
+  type, private :: clock
+     character(len=32) :: name
+#if defined(__sgi) || defined(use_libMPI)
+     integer(LONG_KIND) :: tick
+#else
+     integer :: tick
+#endif
+     integer(LONG_KIND) :: total_ticks
+     integer :: peset_num
+     logical :: sync_on_begin, detailed
+     type(event), pointer :: events(:) !if needed, allocate to MAX_EVENT_TYPES
+  end type
+  type(clock) :: clocks(MAX_CLOCKS)
+
+  integer,parameter :: MAX_BINS=20
+  TYPE :: Clock_Data_Summary
+    character(len=16) :: name
+    real(DOUBLE_KIND) :: msg_size_sums(MAX_BINS)
+    real(DOUBLE_KIND) :: msg_time_sums(MAX_BINS)
+    real(DOUBLE_KIND) :: total_data
+    real(DOUBLE_KIND) :: total_time
+    integer(LONG_KIND) :: msg_size_cnts(MAX_BINS)
+    integer(LONG_KIND) :: total_cnts
+  END TYPE Clock_Data_Summary
+
+  TYPE :: Summary_Struct
+    character(len=16)         :: name
+    type (Clock_Data_Summary) :: event(MAX_EVENT_TYPES)
+  END TYPE Summary_Struct
+  type(Summary_Struct) :: clock_summary(MAX_CLOCKS)
+  
+!public interfaces
+  interface mpp_max
+     module procedure mpp_max_real8
+#ifndef no_8byte_integers
+     module procedure mpp_max_int8
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_max_real4
+#endif
+     module procedure mpp_max_int4
+  end interface
+  interface mpp_min
+     module procedure mpp_min_real8
+#ifndef no_8byte_integers
+     module procedure mpp_min_int8
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_min_real4
+#endif
+     module procedure mpp_min_int4
+  end interface
+  interface mpp_sum
+#ifndef no_8byte_integers
+     module procedure mpp_sum_int8
+     module procedure mpp_sum_int8_scalar
+     module procedure mpp_sum_int8_2d
+     module procedure mpp_sum_int8_3d
+     module procedure mpp_sum_int8_4d
+     module procedure mpp_sum_int8_5d
+#endif
+     module procedure mpp_sum_real8
+     module procedure mpp_sum_real8_scalar
+     module procedure mpp_sum_real8_2d
+     module procedure mpp_sum_real8_3d
+     module procedure mpp_sum_real8_4d
+     module procedure mpp_sum_real8_5d
+     module procedure mpp_sum_cmplx8
+     module procedure mpp_sum_cmplx8_scalar
+     module procedure mpp_sum_cmplx8_2d
+     module procedure mpp_sum_cmplx8_3d
+     module procedure mpp_sum_cmplx8_4d
+     module procedure mpp_sum_cmplx8_5d
+     module procedure mpp_sum_int4
+     module procedure mpp_sum_int4_scalar
+     module procedure mpp_sum_int4_2d
+     module procedure mpp_sum_int4_3d
+     module procedure mpp_sum_int4_4d
+     module procedure mpp_sum_int4_5d
+#ifndef no_4byte_reals
+     module procedure mpp_sum_real4
+     module procedure mpp_sum_real4_scalar
+     module procedure mpp_sum_real4_2d
+     module procedure mpp_sum_real4_3d
+     module procedure mpp_sum_real4_4d
+     module procedure mpp_sum_real4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_sum_cmplx4
+     module procedure mpp_sum_cmplx4_scalar
+     module procedure mpp_sum_cmplx4_2d
+     module procedure mpp_sum_cmplx4_3d
+     module procedure mpp_sum_cmplx4_4d
+     module procedure mpp_sum_cmplx4_5d
+#endif
+  end interface
+  interface mpp_transmit
+     module procedure mpp_transmit_real8
+     module procedure mpp_transmit_real8_scalar
+     module procedure mpp_transmit_real8_2d
+     module procedure mpp_transmit_real8_3d
+     module procedure mpp_transmit_real8_4d
+     module procedure mpp_transmit_real8_5d
+     module procedure mpp_transmit_cmplx8
+     module procedure mpp_transmit_cmplx8_scalar
+     module procedure mpp_transmit_cmplx8_2d
+     module procedure mpp_transmit_cmplx8_3d
+     module procedure mpp_transmit_cmplx8_4d
+     module procedure mpp_transmit_cmplx8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_transmit_int8
+     module procedure mpp_transmit_int8_scalar
+     module procedure mpp_transmit_int8_2d
+     module procedure mpp_transmit_int8_3d
+     module procedure mpp_transmit_int8_4d
+     module procedure mpp_transmit_int8_5d
+     module procedure mpp_transmit_logical8
+     module procedure mpp_transmit_logical8_scalar
+     module procedure mpp_transmit_logical8_2d
+     module procedure mpp_transmit_logical8_3d
+     module procedure mpp_transmit_logical8_4d
+     module procedure mpp_transmit_logical8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_transmit_real4
+     module procedure mpp_transmit_real4_scalar
+     module procedure mpp_transmit_real4_2d
+     module procedure mpp_transmit_real4_3d
+     module procedure mpp_transmit_real4_4d
+     module procedure mpp_transmit_real4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_transmit_cmplx4
+     module procedure mpp_transmit_cmplx4_scalar
+     module procedure mpp_transmit_cmplx4_2d
+     module procedure mpp_transmit_cmplx4_3d
+     module procedure mpp_transmit_cmplx4_4d
+     module procedure mpp_transmit_cmplx4_5d
+#endif
+     module procedure mpp_transmit_int4
+     module procedure mpp_transmit_int4_scalar
+     module procedure mpp_transmit_int4_2d
+     module procedure mpp_transmit_int4_3d
+     module procedure mpp_transmit_int4_4d
+     module procedure mpp_transmit_int4_5d
+     module procedure mpp_transmit_logical4
+     module procedure mpp_transmit_logical4_scalar
+     module procedure mpp_transmit_logical4_2d
+     module procedure mpp_transmit_logical4_3d
+     module procedure mpp_transmit_logical4_4d
+     module procedure mpp_transmit_logical4_5d
+  end interface
+  interface mpp_recv
+     module procedure mpp_recv_real8
+     module procedure mpp_recv_real8_scalar
+     module procedure mpp_recv_real8_2d
+     module procedure mpp_recv_real8_3d
+     module procedure mpp_recv_real8_4d
+     module procedure mpp_recv_real8_5d
+     module procedure mpp_recv_cmplx8
+     module procedure mpp_recv_cmplx8_scalar
+     module procedure mpp_recv_cmplx8_2d
+     module procedure mpp_recv_cmplx8_3d
+     module procedure mpp_recv_cmplx8_4d
+     module procedure mpp_recv_cmplx8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_recv_int8
+     module procedure mpp_recv_int8_scalar
+     module procedure mpp_recv_int8_2d
+     module procedure mpp_recv_int8_3d
+     module procedure mpp_recv_int8_4d
+     module procedure mpp_recv_int8_5d
+     module procedure mpp_recv_logical8
+     module procedure mpp_recv_logical8_scalar
+     module procedure mpp_recv_logical8_2d
+     module procedure mpp_recv_logical8_3d
+     module procedure mpp_recv_logical8_4d
+     module procedure mpp_recv_logical8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_recv_real4
+     module procedure mpp_recv_real4_scalar
+     module procedure mpp_recv_real4_2d
+     module procedure mpp_recv_real4_3d
+     module procedure mpp_recv_real4_4d
+     module procedure mpp_recv_real4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_recv_cmplx4
+     module procedure mpp_recv_cmplx4_scalar
+     module procedure mpp_recv_cmplx4_2d
+     module procedure mpp_recv_cmplx4_3d
+     module procedure mpp_recv_cmplx4_4d
+     module procedure mpp_recv_cmplx4_5d
+#endif
+     module procedure mpp_recv_int4
+     module procedure mpp_recv_int4_scalar
+     module procedure mpp_recv_int4_2d
+     module procedure mpp_recv_int4_3d
+     module procedure mpp_recv_int4_4d
+     module procedure mpp_recv_int4_5d
+     module procedure mpp_recv_logical4
+     module procedure mpp_recv_logical4_scalar
+     module procedure mpp_recv_logical4_2d
+     module procedure mpp_recv_logical4_3d
+     module procedure mpp_recv_logical4_4d
+     module procedure mpp_recv_logical4_5d
+  end interface
+  interface mpp_send
+     module procedure mpp_send_real8
+     module procedure mpp_send_real8_scalar
+     module procedure mpp_send_real8_2d
+     module procedure mpp_send_real8_3d
+     module procedure mpp_send_real8_4d
+     module procedure mpp_send_real8_5d
+     module procedure mpp_send_cmplx8
+     module procedure mpp_send_cmplx8_scalar
+     module procedure mpp_send_cmplx8_2d
+     module procedure mpp_send_cmplx8_3d
+     module procedure mpp_send_cmplx8_4d
+     module procedure mpp_send_cmplx8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_send_int8
+     module procedure mpp_send_int8_scalar
+     module procedure mpp_send_int8_2d
+     module procedure mpp_send_int8_3d
+     module procedure mpp_send_int8_4d
+     module procedure mpp_send_int8_5d
+     module procedure mpp_send_logical8
+     module procedure mpp_send_logical8_scalar
+     module procedure mpp_send_logical8_2d
+     module procedure mpp_send_logical8_3d
+     module procedure mpp_send_logical8_4d
+     module procedure mpp_send_logical8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_send_real4
+     module procedure mpp_send_real4_scalar
+     module procedure mpp_send_real4_2d
+     module procedure mpp_send_real4_3d
+     module procedure mpp_send_real4_4d
+     module procedure mpp_send_real4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_send_cmplx4
+     module procedure mpp_send_cmplx4_scalar
+     module procedure mpp_send_cmplx4_2d
+     module procedure mpp_send_cmplx4_3d
+     module procedure mpp_send_cmplx4_4d
+     module procedure mpp_send_cmplx4_5d
+#endif
+     module procedure mpp_send_int4
+     module procedure mpp_send_int4_scalar
+     module procedure mpp_send_int4_2d
+     module procedure mpp_send_int4_3d
+     module procedure mpp_send_int4_4d
+     module procedure mpp_send_int4_5d
+     module procedure mpp_send_logical4
+     module procedure mpp_send_logical4_scalar
+     module procedure mpp_send_logical4_2d
+     module procedure mpp_send_logical4_3d
+     module procedure mpp_send_logical4_4d
+     module procedure mpp_send_logical4_5d
+  end interface
+
+  interface mpp_broadcast
+     module procedure mpp_broadcast_real8
+     module procedure mpp_broadcast_real8_scalar
+     module procedure mpp_broadcast_real8_2d
+     module procedure mpp_broadcast_real8_3d
+     module procedure mpp_broadcast_real8_4d
+     module procedure mpp_broadcast_real8_5d
+     module procedure mpp_broadcast_cmplx8
+     module procedure mpp_broadcast_cmplx8_scalar
+     module procedure mpp_broadcast_cmplx8_2d
+     module procedure mpp_broadcast_cmplx8_3d
+     module procedure mpp_broadcast_cmplx8_4d
+     module procedure mpp_broadcast_cmplx8_5d
+#ifndef no_8byte_integers
+     module procedure mpp_broadcast_int8
+     module procedure mpp_broadcast_int8_scalar
+     module procedure mpp_broadcast_int8_2d
+     module procedure mpp_broadcast_int8_3d
+     module procedure mpp_broadcast_int8_4d
+     module procedure mpp_broadcast_int8_5d
+     module procedure mpp_broadcast_logical8
+     module procedure mpp_broadcast_logical8_scalar
+     module procedure mpp_broadcast_logical8_2d
+     module procedure mpp_broadcast_logical8_3d
+     module procedure mpp_broadcast_logical8_4d
+     module procedure mpp_broadcast_logical8_5d
+#endif
+#ifndef no_4byte_reals
+     module procedure mpp_broadcast_real4
+     module procedure mpp_broadcast_real4_scalar
+     module procedure mpp_broadcast_real4_2d
+     module procedure mpp_broadcast_real4_3d
+     module procedure mpp_broadcast_real4_4d
+     module procedure mpp_broadcast_real4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_broadcast_cmplx4
+     module procedure mpp_broadcast_cmplx4_scalar
+     module procedure mpp_broadcast_cmplx4_2d
+     module procedure mpp_broadcast_cmplx4_3d
+     module procedure mpp_broadcast_cmplx4_4d
+     module procedure mpp_broadcast_cmplx4_5d
+#endif
+     module procedure mpp_broadcast_int4
+     module procedure mpp_broadcast_int4_scalar
+     module procedure mpp_broadcast_int4_2d
+     module procedure mpp_broadcast_int4_3d
+     module procedure mpp_broadcast_int4_4d
+     module procedure mpp_broadcast_int4_5d
+     module procedure mpp_broadcast_logical4
+     module procedure mpp_broadcast_logical4_scalar
+     module procedure mpp_broadcast_logical4_2d
+     module procedure mpp_broadcast_logical4_3d
+     module procedure mpp_broadcast_logical4_4d
+     module procedure mpp_broadcast_logical4_5d
+  end interface
+
+  interface mpp_chksum
+#ifndef no_8byte_integers
+     module procedure mpp_chksum_i8_1d
+     module procedure mpp_chksum_i8_2d
+     module procedure mpp_chksum_i8_3d
+     module procedure mpp_chksum_i8_4d
+#endif
+     module procedure mpp_chksum_i4_1d
+     module procedure mpp_chksum_i4_2d
+     module procedure mpp_chksum_i4_3d
+     module procedure mpp_chksum_i4_4d
+     module procedure mpp_chksum_r8_0d
+     module procedure mpp_chksum_r8_1d
+     module procedure mpp_chksum_r8_2d
+     module procedure mpp_chksum_r8_3d
+     module procedure mpp_chksum_r8_4d
+     module procedure mpp_chksum_r8_5d
+     module procedure mpp_chksum_c8_0d
+     module procedure mpp_chksum_c8_1d
+     module procedure mpp_chksum_c8_2d
+     module procedure mpp_chksum_c8_3d
+     module procedure mpp_chksum_c8_4d
+     module procedure mpp_chksum_c8_5d
+#ifndef no_4byte_reals
+     module procedure mpp_chksum_r4_0d
+     module procedure mpp_chksum_r4_1d
+     module procedure mpp_chksum_r4_2d
+     module procedure mpp_chksum_r4_3d
+     module procedure mpp_chksum_r4_4d
+     module procedure mpp_chksum_r4_5d
+#endif
+#ifndef no_4byte_cmplx
+     module procedure mpp_chksum_c4_0d
+     module procedure mpp_chksum_c4_1d
+     module procedure mpp_chksum_c4_2d
+     module procedure mpp_chksum_c4_3d
+     module procedure mpp_chksum_c4_4d
+     module procedure mpp_chksum_c4_5d
+#endif
+  end interface
+
+  interface mpp_error
+     module procedure mpp_error_basic
+     module procedure mpp_error_mesg
+     module procedure mpp_error_noargs
+  end interface
+
+#ifdef use_libSMA
+!currently SMA contains no generic shmem_wait for different integer kinds:
+!I have inserted one here
+  interface shmem_integer_wait
+     module procedure shmem_int4_wait_local
+     module procedure shmem_int8_wait_local
+  end interface
+#endif
+  public :: mpp_chksum, mpp_max, mpp_min, mpp_sum
+  public :: mpp_exit, mpp_init
+  public :: mpp_pe, mpp_node, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_set_stack_size
+  public :: mpp_clock_begin, mpp_clock_end, mpp_clock_id, mpp_clock_set_grain
+  public :: mpp_error, mpp_error_state, mpp_set_warn_level
+  public :: mpp_sync, mpp_sync_self
+  public :: mpp_transmit, mpp_send, mpp_recv, mpp_broadcast
+  public :: stdin, stdout, stderr, stdlog
+  public :: mpp_declare_pelist, mpp_get_current_pelist, mpp_set_current_pelist
+#ifdef use_shmalloc
+  public :: mpp_malloc
+#endif
+
+  contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!       ROUTINES TO INITIALIZE/FINALIZE MPP MODULE: mpp_init, mpp_exit        !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_init( flags,mpp_comm ,logfile)
+      integer, optional, intent(in) :: flags,mpp_comm
+      character(len=*), optional, intent(in) :: logfile
+!    subroutine mpp_init( flags, in, out, err, log )
+!      integer, optional, intent(in) :: flags, in, out, err, log
+      integer :: my_pe, num_pes, len
+      integer :: i
+      integer :: comm_intern
+      logical :: opened
+#ifdef _CRAYT3E
+      intrinsic my_pe
+#endif
+
+      if( module_is_initialized )return
+
+#ifdef use_libSMA
+      call START_PES(0)         !the argument 0 means extract from environment variable NPES on PVP/SGI, from mpprun -n on t3e
+      pe = my_pe()
+      node = pe                 !on an SMP this should return node ID rather than PE number.
+      npes = num_pes()
+#elif use_libMPI
+      call MPI_INITIALIZED( opened, error ) !in case called from another MPI package
+      if(PRESENT(mpp_comm)) then
+        comm_intern=mpp_comm
+      else
+        comm_intern=MPI_COMM_WORLD
+      endif
+!
+      if(present(logfile)) then
+        etcfile=trim(logfile)
+        configfile=trim(logfile)
+        logfile_defined=.true.
+      endif
+!
+      if( .NOT.opened )then
+      call MPI_INIT(error)
+        comm_intern=MPI_COMM_WORLD
+      endif
+      call MPI_COMM_RANK(  comm_intern, pe,   error )
+      call MPI_COMM_SIZE(  comm_intern, npes, error )
+      allocate( request(0:npes-1) )
+      request(:) = MPI_REQUEST_NULL
+#endif
+      module_is_initialized = .TRUE.
+
+!PEsets: make defaults illegal
+      peset(:)%count = -1
+#ifdef use_libSMA
+      peset(:)%start = -1
+      peset(:)%log2stride = -1
+#elif use_libMPI
+      peset(:)%id = -1
+      peset(:)%group = -1
+#endif
+!0=single-PE, initialized so that count returns 1
+      peset(0)%count = 1
+      allocate( peset(0)%list(1) )
+      peset(0)%list = pe
+#ifdef use_libMPI
+      current_peset_num = 0
+      peset(0)%id = comm_intern
+      call MPI_COMM_GROUP(  peset(0)%id, peset(0)%group, error )
+#endif
+      world_peset_num = get_peset( (/(i,i=0,npes-1)/) )
+      current_peset_num = world_peset_num !initialize current PEset to world
+
+!initialize clocks
+      call SYSTEM_CLOCK( count=tick0, count_rate=ticks_per_sec, count_max=max_ticks )
+      tick_rate = 1./ticks_per_sec
+      clock0 = mpp_clock_id( 'Total runtime', flags=MPP_CLOCK_SYNC )
+
+      if( PRESENT(flags) )then
+          debug   = flags.EQ.MPP_DEBUG
+          verbose = flags.EQ.MPP_VERBOSE .OR. debug
+      end if
+
+#ifdef use_libSMA
+#ifdef use_shmalloc
+!we use shpalloc to ensure all these are remotely accessible
+      len=0; ptr_sync = LOC(pe)   !null initialization
+      call mpp_malloc( ptr_sync,        size(TRANSFER(sync,word)),            len )
+      len=0; ptr_status = LOC(pe)  !null initialization
+      call mpp_malloc( ptr_status, npes*size(TRANSFER(status(0),word)),   len )
+      len=0; ptr_remote = LOC(pe) !null initialization
+      call mpp_malloc( ptr_remote, npes*size(TRANSFER(remote_data_loc(0),word)), len )
+      len=0; ptr_from = LOC(pe)   !null initialization
+      call mpp_malloc( ptr_from,        size(TRANSFER(mpp_from_pe,word)),     len )
+#else
+      allocate( status(0:npes-1) )
+      allocate( remote_data_loc(0:npes-1) )
+#endif
+      sync(:) = SHMEM_SYNC_VALUE
+      status(0:npes-1) = MPP_READY
+      remote_data_loc(0:npes-1) = MPP_WAIT
+      call mpp_set_stack_size(32768) !default initial value
+#endif
+
+!logunit: log messages are written to configfile.out by default
+      etc_unit=get_unit()
+!      write( etcfile,'(a,i4.4)' )trim(etcfile)//'.', pe
+!rv
+!rv Status 'REPLACE' eads to an unpredictable behaviour on SX-6
+!rv      if( pe.EQ.root_pe )open( unit=etc_unit, file=trim(etcfile), status='REPLACE' )
+!rv
+      if( pe.EQ.root_pe )then
+          if(logfile_defined) then
+            inquire( file=trim(etcfile), opened=opened,number=io_num)
+            if(opened) then
+              etc_unit=io_num
+            else
+              open( unit=etc_unit, file=trim(etcfile), status='UNKNOWN' )
+              close(etc_unit)
+            endif
+          else
+            open( unit=etc_unit, file=trim(etcfile), status='UNKNOWN' )
+            close(etc_unit)
+          endif
+      endif
+
+      call mpp_sync()                         
+!rv
+      if(present(logfile)) then
+        inquire( file=trim(etcfile), opened=opened,number=io_num)
+        if(opened) then
+          if( pe.NE.root_pe ) then
+            etc_unit=io_num
+          endif
+        else
+          if( pe.NE.root_pe ) then
+            open( unit=etc_unit, file=trim(etcfile), status='UNKNOWN' )
+            close(etc_unit)
+          endif
+        endif
+      else
+        if( pe.NE.root_pe ) then
+          open( unit=etc_unit, file=trim(etcfile), status='OLD' )
+          close(etc_unit)
+        endif
+      endif
+!            write(0,*)'etc_unit=',etc_unit
+!rv
+
+!if optional argument logunit=stdout, write messages to stdout instead.
+!if specifying non-defaults, you must specify units not yet in use.
+!      if( PRESENT(in) )then
+!          inquire( unit=in, opened=opened )
+!          if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stdin.' )
+!          in_unit=in
+!      end if
+!      if( PRESENT(out) )then
+!          inquire( unit=out, opened=opened )
+!          if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stdout.' )
+!          out_unit=out
+!      end if
+!      if( PRESENT(err) )then
+!          inquire( unit=err, opened=opened )
+!          if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stderr.' )
+!          err_unit=err
+!      end if
+!      log_unit=get_unit()
+!      if( PRESENT(log) )then
+!          inquire( unit=log, opened=opened )
+!          if( opened .AND. log.NE.out_unit )call mpp_error( FATAL, 'MPP_INIT: unable to open stdlog.' )
+!          log_unit=log
+!      end if
+!!log_unit can be written to only from root_pe, all others write to stdout
+!      if( log_unit.NE.out_unit )then
+!          inquire( unit=log_unit, opened=opened )
+!          if( opened )call mpp_error( FATAL, 'MPP_INIT: specified unit for stdlog already in use.' )
+!          if( pe.EQ.root_pe )open( unit=log_unit, file=trim(configfile), status='REPLACE' )
+!          call mpp_sync()
+!          if( pe.NE.root_pe )open( unit=log_unit, file=trim(configfile), status='OLD' )
+!      end if
+      if( pe.EQ.root_pe )then
+          log_unit = get_unit()
+!rv Status 'REPLACE' leads to an unpredictable  behaviour on the SX-6.
+!rv          open( unit=log_unit, file=trim(configfile), status='REPLACE' )
+        if(logfile_defined) then
+          inquire( file=trim(configfile), opened=opened,number=io_num)
+          if(opened)then
+            log_unit=io_num
+          else
+            open( unit=log_unit, file=trim(configfile), status='UNKNOWN' )
+            close(log_unit)
+          endif
+        else
+          open( unit=log_unit, file=trim(configfile), status='UNKNOWN' )
+          close(log_unit)
+        endif
+      end if
+!messages
+      if( verbose )call mpp_error( NOTE, 'MPP_INIT: initializing MPP module...' )
+      if( pe.EQ.root_pe )then
+          write( stdlog(),'(/a)' )'MPP module '//trim(version)//trim(tagname)
+          write( stdlog(),'(a,i4)' )'MPP started with NPES=', npes
+#ifdef use_libSMA
+          write( stdlog(),'(a)' )'Using SMA (shmem) library for message passing...'
+#endif
+#ifdef use_libMPI
+          write( stdlog(),'(a)' )'Using MPI library for message passing...'
+#endif
+          write( stdlog(), '(a,es12.4,a,i20,a)' ) &
+               'Realtime clock resolution=', tick_rate, ' sec (', ticks_per_sec, ' ticks/sec)'
+          write( stdlog(), '(a,es12.4,a,i20,a)' ) &
+               'Clock rolls over after ', max_ticks*tick_rate, ' sec (', max_ticks, ' ticks)'
+      end if
+      call mpp_clock_begin(clock0)
+
+      return
+    end subroutine mpp_init
+
+    function stdin()
+      integer :: stdin
+      stdin = in_unit
+      return
+    end function stdin
+
+    function stdout()
+      integer :: stdout
+      integer::tmp_unit
+      logical::opened
+      stdout = out_unit
+      if( pe.NE.root_pe )stdout = etc_unit
+      if(logfile_defined)then
+
+        if( pe.EQ.root_pe )then
+            inquire( file=trim(etcfile), opened=opened ,number=tmp_unit)
+            if( opened )then
+
+                out_unit=tmp_unit
+                stdout=out_unit
+!              write(0,*) 'stdout:',tmp_unit,etcfile
+                call FLUSH(out_unit)
+
+            else
+                tmp_unit=get_unit()
+!              write(0,*) 'stdout(not):',tmp_unit,etcfile
+!ac
+                open( unit=tmp_unit, status='UNKNOWN', file=trim(etcfile), err=10 )
+!ac
+              out_unit=tmp_unit
+            end if
+
+            stdout = out_unit
+
+        endif
+        
+      endif
+      return
+ 10 logfile_defined=.false.
+    call mpp_error( FATAL, 'STDOUT: unable to open '//trim(etcfile))
+    end function stdout
+
+    function stderr()
+      integer :: stderr
+      integer :: tmp_unit
+      logical :: opened
+
+      stderr = err_unit
+
+      if(logfile_defined)then
+
+        if( pe.EQ.root_pe )then
+            inquire( file=trim(configfile), opened=opened ,number=tmp_unit)
+            if( opened )then
+                err_unit=tmp_unit
+                stderr=err_unit
+                call FLUSH(err_unit)
+!              write(0,*) 'stderr:',tmp_unit
+            else
+!              write(0,*) 'stderr(not):',tmp_unit
+                tmp_unit=get_unit()
+!ac
+                open( unit=tmp_unit, status='UNKNOWN', file=trim(configfile), err=10 )
+!ac
+              err_unit=tmp_unit
+            end if
+
+            stderr = err_unit
+
+        endif
+        
+      endif
+      return
+
+ 10 logfile_defined=.false.
+    call mpp_error( FATAL, 'STDERR: unable to open '//trim(configfile))
+
+    end function stderr
+
+    function stdlog()
+      integer :: stdlog
+      logical :: opened
+      if( pe.EQ.root_pe )then
+          inquire( file=trim(configfile), opened=opened )
+          if( opened )then
+	      call FLUSH(log_unit)
+          else
+              log_unit=get_unit()
+!ac
+              open( unit=log_unit, status='UNKNOWN', file=trim(configfile), err=10 )
+!ac
+          end if
+          stdlog = log_unit
+      else
+          stdlog = etc_unit
+      end if
+      return
+   10 call mpp_error( FATAL, 'STDLOG: unable to open '//trim(configfile)//'.' )
+    end function stdlog
+
+    subroutine mpp_exit()
+!to be called at the end of a run
+      integer :: i, j, k, n, nmax
+      real :: t, tmin, tmax, tavg, tstd
+      real :: m, mmin, mmax, mavg, mstd
+      real :: t_total
+
+      if( .NOT.module_is_initialized )return
+      call mpp_clock_end(clock0)
+      t_total = clocks(clock0)%total_ticks*tick_rate
+      if( clock_num.GT.0 )then
+          if( ANY(clocks(1:clock_num)%detailed) )then
+              call sum_clock_data; call dump_clock_summary
+          end if
+          if( pe.EQ.root_pe )then
+              write( stdout(),'(/a,i4,a)' ) 'Tabulating mpp_clock statistics across ', npes, ' PEs...'
+              if( ANY(clocks(1:clock_num)%detailed) ) &
+                   write( stdout(),'(a)' )'   ... see mpp_clock.out.#### for details on individual PEs.'
+              write( stdout(),'(/32x,a)' ) '          tmin          tmax          tavg          tstd  tfrac'
+          end if
+          do i = 1,clock_num
+             call mpp_set_current_pelist() !implied global barrier
+             current_peset_num = clocks(i)%peset_num
+             if( .NOT.ANY(peset(current_peset_num)%list(:).EQ.pe) )cycle
+!times between mpp_clock ticks
+             t = clocks(i)%total_ticks*tick_rate
+             tmin = t; call mpp_min(tmin)
+             tmax = t; call mpp_max(tmax)
+             tavg = t; call mpp_sum(tavg); tavg = tavg/mpp_npes()
+             tstd = (t-tavg)**2; call mpp_sum(tstd); tstd = sqrt( tstd/mpp_npes() )
+             if( pe.EQ.root_pe )write( stdout(),'(a32,4f14.6,f7.3)' ) &
+                  clocks(i)%name, tmin, tmax, tavg, tstd, tavg/t_total
+          end do
+          if( ANY(clocks(1:clock_num)%detailed) .AND. pe.EQ.root_pe )write( stdout(),'(/32x,a)' ) &
+               '       tmin       tmax       tavg       tstd       mmin       mmax       mavg       mstd  mavg/tavg'
+          do i = 1,clock_num
+!messages: bytelengths and times
+	     if( .NOT.clocks(i)%detailed )cycle
+             do j = 1,MAX_EVENT_TYPES
+                n = clocks(i)%events(j)%calls; nmax = n
+                call mpp_max(nmax)
+                if( nmax.NE.0 )then
+!don't divide by n because n might be 0
+                    m = 0
+                    if( n.GT.0 )m = sum(clocks(i)%events(j)%bytes(1:n))
+                    mmin = m; call mpp_min(mmin)
+                    mmax = m; call mpp_max(mmax)
+                    mavg = m; call mpp_sum(mavg); mavg = mavg/mpp_npes()
+                    mstd = (m-mavg)**2; call mpp_sum(mstd); mstd = sqrt( mstd/mpp_npes() )
+                    t = 0
+                    if( n.GT.0 )t = sum(clocks(i)%events(j)%ticks(1:n))*tick_rate
+                    tmin = t; call mpp_min(tmin)
+                    tmax = t; call mpp_max(tmax)
+                    tavg = t; call mpp_sum(tavg); tavg = tavg/mpp_npes()
+                    tstd = (t-tavg)**2; call mpp_sum(tstd); tstd = sqrt( tstd/mpp_npes() )
+                    if( pe.EQ.root_pe )write( stdout(),'(a32,4f11.3,5es11.3)' ) &
+                         trim(clocks(i)%name)//' '//trim(clocks(i)%events(j)%name), &
+                         tmin, tmax, tavg, tstd, mmin, mmax, mavg, mstd, mavg/tavg
+                end if
+             end do
+          end do
+      end if
+      call mpp_set_current_pelist()
+      call mpp_sync()
+      call mpp_max(mpp_stack_hwm)
+      if( pe.EQ.root_pe )write( stdout(),* )'MPP_STACK high water mark=', mpp_stack_hwm
+#ifdef use_libMPI
+!reiner Let's do the MPI_finalize outside the mpp environment
+!reiner      call MPI_FINALIZE(error)
+#endif
+
+      return
+    end subroutine mpp_exit
+
+    function mpp_pe()
+      integer :: mpp_pe
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_PE: You must first call mpp_init.' )
+      mpp_pe = pe
+      return
+    end function mpp_pe
+
+    function mpp_node()
+      integer :: mpp_node
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_NODE: You must first call mpp_init.' )
+      mpp_node = node
+      return
+    end function mpp_node
+
+    function mpp_npes()
+      integer :: mpp_npes
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_NPES: You must first call mpp_init.' )
+!      mpp_npes = npes
+      mpp_npes = size(peset(current_peset_num)%list)
+      return
+    end function mpp_npes
+
+    function mpp_root_pe()
+      integer :: mpp_root_pe
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_ROOT_PE: You must first call mpp_init.' )
+      mpp_root_pe = root_pe
+      return
+    end function mpp_root_pe
+
+    subroutine mpp_set_root_pe(num)
+      integer, intent(in) :: num
+      logical :: opened
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_ROOT_PE: You must first call mpp_init.' )
+      if( .NOT.(ANY(num.EQ.peset(current_peset_num)%list)) ) &
+           call mpp_error( FATAL, 'MPP_SET_ROOT_PE: you cannot set a root PE outside the current pelist.' )
+!actions to take if root_pe has changed:
+! open log_unit on new root_pe, close it on old root_pe and point its log_unit to stdout.
+!      if( num.NE.root_pe )then  !root_pe has changed
+!          if( pe.EQ.num )then
+!!on the new root_pe
+!              if( log_unit.NE.out_unit )then
+!                  inquire( unit=log_unit, opened=opened )
+!                  if( .NOT.opened )open( unit=log_unit, status='OLD', file=trim(configfile), position='APPEND' )
+!              end if
+!          else if( pe.EQ.root_pe )then
+!!on the old root_pe
+!              if( log_unit.NE.out_unit )then
+!                  inquire( unit=log_unit, opened=opened )
+!                  if( opened )close(log_unit)
+!                  log_unit = out_unit
+!              end if
+!          end if
+!      end if
+      root_pe = num
+      return
+    end subroutine mpp_set_root_pe
+
+    subroutine mpp_declare_pelist( pelist, name )
+!this call is written specifically to accommodate a brain-dead MPI restriction
+!that requires a parent communicator to create a child communicator:
+!in other words: a pelist cannot go off and declare a communicator, but every PE
+!in the parent, including those not in pelist(:), must get together for the
+!MPI_COMM_CREATE call. The parent is typically  peset(0)%id, though it could also
+!be a subset that includes all PEs in pelist.
+!This restriction does not apply to SMA but to have uniform code,
+!you may as well call it. It must be placed in a context where all PEs call it.
+!Subsequent calls that use the pelist should be called PEs in the pelist only.
+      integer, intent(in) :: pelist(:)
+      character(len=*), optional :: name
+      integer :: i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DECLARE_PELIST: You must first call mpp_init.' )
+      i = get_peset(pelist)
+      write( peset(i)%name,'(a,i2.2)' ) 'PElist', i !default name
+      if( PRESENT(name) )peset(i)%name = name
+      return
+    end subroutine mpp_declare_pelist
+
+    subroutine mpp_set_current_pelist( pelist )
+!Once we branch off into a PE subset, we want subsequent "global" calls to
+!sync only across this subset. This is declared as the current pelist (peset(current_peset_num)%list)
+!when current_peset all pelist ops with no pelist should apply the current pelist.
+!also, we set the start PE in this pelist to be the root_pe.
+!unlike mpp_declare_pelist, this is called by the PEs in the pelist only
+!so if the PEset has not been previously declared, this will hang in MPI.
+!if pelist is omitted, we reset pelist to the world pelist.
+      integer, intent(in), optional :: pelist(:)
+      integer :: i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_CURRENT_PELIST: You must first call mpp_init.' )
+      if( PRESENT(pelist) )then
+          if( .NOT.ANY(pe.EQ.pelist) )call mpp_error( FATAL, 'MPP_SET_CURRENT_PELIST: pe must be in pelist.' )
+          current_peset_num = get_peset(pelist)
+      else
+          current_peset_num = world_peset_num
+      end if
+      call mpp_set_root_pe( MINVAL(peset(current_peset_num)%list) )
+      call mpp_sync()           !this is called to make sure everyone in the current pelist is here.
+!      npes = mpp_npes()
+      return
+    end subroutine mpp_set_current_pelist
+
+    subroutine mpp_get_current_pelist( pelist, name )
+!this is created for use by mpp_define_domains within a pelist
+!will be published but not publicized
+      integer, intent(out) :: pelist(:)
+      character(len=*), intent(out), optional :: name
+
+      if( size(pelist).NE.size(peset(current_peset_num)%list) ) &
+           call mpp_error( FATAL, 'MPP_GET_CURRENT_PELIST: size(pelist) is wrong.' )
+      pelist(:) = peset(current_peset_num)%list(:)
+      if( PRESENT(name) )name = peset(current_peset_num)%name
+
+      return
+    end subroutine mpp_get_current_pelist
+
+    function get_peset(pelist)
+      integer :: get_peset
+!makes a PE set out of a PE list
+!a PE list is an ordered list of PEs
+!a PE set is a triad (start,log2stride,size) for SHMEM, an a communicator for MPI
+!if stride is non-uniform or not a power of 2, will return error (not required for MPI but enforced for uniformity)
+      integer, intent(in), optional :: pelist(:)
+      integer :: group
+      integer :: i, n, stride
+      integer, allocatable :: sorted(:)
+
+      if( .NOT.PRESENT(pelist) )then !set it to current_peset_num
+          get_peset = current_peset_num; return
+      end if
+      if( size(pelist).EQ.1 .AND. npes.GT.1 )then    !collective ops on single PEs should return
+          get_peset = 0; return
+      end if
+!make a sorted list
+      n = 1
+      if( ascend_sort(pelist).NE.1 )call mpp_error( FATAL, 'GET_PESET: sort error.' )   !result is the array sorted(:)
+      if( debug )write( stderr(),* )'pelist=', pelist, ' sorted=', sorted
+!find if this array matches any existing peset
+      do i = 1,peset_num
+         if( debug )write( stderr(),'(a,3i4)' )'pe, i, peset_num=', pe, i, peset_num
+         if( size(sorted).EQ.size(peset(i)%list) )then
+             if( ALL(sorted.EQ.peset(i)%list) )then
+                 deallocate(sorted)
+                 get_peset = i; return
+             end if
+         end if
+      end do
+!not found, so create new peset
+      peset_num = peset_num + 1
+      if( peset_num.GE.PESET_MAX )call mpp_error( FATAL, 'GET_PESET: number of PE sets exceeds PESET_MAX.' )
+      i = peset_num             !shorthand
+!create list
+      allocate( peset(i)%list(size(sorted)) )
+      peset(i)%list(:) = sorted(:)
+      peset(i)%count = size(sorted)
+#ifdef use_libSMA
+      peset(i)%start = sorted(1)
+      if( size(sorted).GT.1 )then
+          stride = sorted(2)-sorted(1)
+          if( ANY(sorted(2:n)-sorted(1:n-1).NE.stride) ) &
+               call mpp_error( WARNING, 'GET_PESET: pelist must have constant stride.' )
+          peset(i)%log2stride = nint( log(real(stride))/log(2.) )
+          if( 2**peset(i)%log2stride.NE.stride )call mpp_error( WARNING, 'GET_PESET: pelist must have power-of-2 stride.' )
+      else
+          peset(i)%log2stride = 0
+      end if
+#elif use_libMPI
+      call MPI_GROUP_INCL( peset(current_peset_num)%group, size(sorted), sorted, peset(i)%group, error )
+      call MPI_COMM_CREATE( peset(current_peset_num)%id, peset(i)%group, peset(i)%id, error )
+#endif
+      deallocate(sorted)
+      get_peset = i
+
+      return
+
+      contains
+        
+        recursive function ascend_sort(a) result(a_sort)
+          integer :: a_sort
+          integer, intent(in) :: a(:)
+          integer :: b, i
+          if( size(a).EQ.1 .OR. ALL(a.EQ.a(1)) )then
+              allocate( sorted(n) )
+              sorted(n) = a(1)
+              a_sort = n
+              return
+          end if
+          b = minval(a)
+          n = n + 1
+          i = ascend_sort( pack(a,mask=a.NE.b) )
+          a_sort = i - 1
+          sorted(i-1) = b
+          return
+        end function ascend_sort
+
+    end function get_peset
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                        PERFORMANCE PROFILING CALLS                          !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    subroutine mpp_clock_set_grain( grain )
+      integer, intent(in) :: grain
+!set the granularity of times: only clocks whose grain is lower than
+!clock_grain are triggered, finer-grained clocks are dormant.
+!clock_grain is initialized to HUGE(1), so all clocks are triggered if
+!this is never called.   
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_SET_GRAIN: You must first call mpp_init.' )
+
+      clock_grain = grain
+      return
+    end subroutine mpp_clock_set_grain
+
+    function mpp_clock_id( name, flags, grain )
+!return an ID for a new or existing clock
+      integer :: mpp_clock_id
+      character(len=*), intent(in) :: name
+      integer, intent(in), optional :: flags, grain
+      integer :: i
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_ID: You must first call mpp_init.' )
+!if grain is present, the clock is only triggered if it
+!is low ("coarse") enough: compared to clock_grain
+!finer-grained clocks are dormant.
+!if grain is absent, clock is triggered.
+      if( PRESENT(grain) )then
+          if( grain.GT.clock_grain )then
+              mpp_clock_id = 0
+              return
+          end if
+      end if
+      mpp_clock_id = 1
+      if( clock_num.EQ.0 )then  !first
+!         allocate( clocks(MAX_CLOCKS) )
+          clock_num = mpp_clock_id
+          call clock_init(mpp_clock_id,name,flags)
+      else
+          FIND_CLOCK: do while( trim(name).NE.trim(clocks(mpp_clock_id)%name) )
+             mpp_clock_id = mpp_clock_id + 1
+             if( mpp_clock_id.GT.clock_num )then
+                 if( mpp_clock_id.GT.MAX_CLOCKS )then
+                     call mpp_error( WARNING, 'MPP_CLOCK_ID: too many clock requests, this one is ignored.' )
+                 else               !new clock: initialize
+                     clock_num = mpp_clock_id
+                     call clock_init(mpp_clock_id,name,flags)
+                     exit FIND_CLOCK
+                 end if
+             end if
+          end do FIND_CLOCK
+      endif
+      return
+    end function mpp_clock_id
+
+    subroutine mpp_clock_begin(id)
+      integer, intent(in) :: id
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: You must first call mpp_init.' )
+      if( id.EQ.0 )return
+      if( id.LT.0 .OR. id.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid id.' )
+
+      if( clocks(id)%peset_num.EQ.0 )clocks(id)%peset_num = current_peset_num
+      if( clocks(id)%peset_num.NE.current_peset_num ) &
+           call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: cannot change pelist context of a clock.' )
+      if( clocks(id)%sync_on_begin )then
+!do an untimed sync at the beginning of the clock
+!this puts all PEs in the current pelist on par, so that measurements begin together
+!ending time will be different, thus measuring load imbalance for this clock.
+          current_clock = 0; call mpp_sync()
+      end if
+      current_clock = id
+      call SYSTEM_CLOCK( clocks(id)%tick )
+      return
+    end subroutine mpp_clock_begin
+
+    subroutine mpp_clock_end(id)
+!the id argument is not used for anything at present
+      integer, intent(in), optional :: id
+      integer(LONG_KIND) :: delta
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_END: You must first call mpp_init.' )
+      if( id.EQ.0 )return
+      if( id.LT.0 .OR. id.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid id.' )
+      call SYSTEM_CLOCK(end_tick)
+      if( clocks(id)%peset_num.NE.current_peset_num ) &
+           call mpp_error( FATAL, 'MPP_CLOCK_END: cannot change pelist context of a clock.' )
+      delta = end_tick - clocks(id)%tick
+      if( delta.LT.0 )then
+          write( stderr(),* )'pe, id, start_tick, end_tick, delta, max_ticks=', pe, id, clocks(id)%tick, end_tick, delta, max_ticks
+          delta = delta + max_ticks + 1
+          call mpp_error( WARNING, 'MPP_CLOCK_END: Clock rollover, assumed single roll.' )
+      end if
+      clocks(id)%total_ticks = clocks(id)%total_ticks + delta
+      current_clock = 0
+      return
+    end subroutine mpp_clock_end
+
+    subroutine increment_current_clock( event_id, bytes )
+      integer, intent(in) :: event_id
+      integer, intent(in), optional :: bytes
+      integer :: n
+      integer(LONG_KIND) :: delta
+
+      if( current_clock.EQ.0 )return
+      if( current_clock.LT.0 .OR. current_clock.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid current_clock.' )
+      if( .NOT.clocks(current_clock)%detailed )return
+      call SYSTEM_CLOCK(end_tick)
+      n = clocks(current_clock)%events(event_id)%calls + 1
+
+      if( n.EQ.MAX_EVENTS )call mpp_error( WARNING, &
+           'MPP_CLOCK: events exceed MAX_EVENTS, ignore detailed profiling data for clock '//trim(clocks(current_clock)%name) )
+      if( n.GT.MAX_EVENTS )return
+
+      clocks(current_clock)%events(event_id)%calls = n
+      delta = end_tick - start_tick
+      if( delta.LT.0 )then
+          delta = delta + max_ticks + 1
+          call mpp_error( WARNING, 'MPP_CLOCK_END: Clock rollover, assumed single roll.' )
+      end if
+      clocks(current_clock)%events(event_id)%ticks(n) = delta
+      if( PRESENT(bytes) )clocks(current_clock)%events(event_id)%bytes(n) = bytes
+      return
+    end subroutine increment_current_clock
+
+  subroutine dump_clock_summary()
+    implicit none
+
+    real :: total_time,total_time_all,total_data
+    real :: msg_size,eff_BW,s
+    integer :: SD_UNIT
+    integer :: total_calls
+    integer :: i,j,k,ct
+    integer :: msg_cnt
+    character(len=2)  :: u
+    character(len=18) :: filename
+    character(len=20),dimension(MAX_BINS),save :: bin
+
+    data bin( 1)  /'  0   -    8    B:  '/
+    data bin( 2)  /'  8   -   16    B:  '/
+    data bin( 3)  /' 16   -   32    B:  '/
+    data bin( 4)  /' 32   -   64    B:  '/
+    data bin( 5)  /' 64   -  128    B:  '/
+    data bin( 6)  /'128   -  256    B:  '/
+    data bin( 7)  /'256   -  512    B:  '/
+    data bin( 8)  /'512   - 1024    B:  '/
+    data bin( 9)  /'  1.0 -    2.1 KB:  '/
+    data bin(10)  /'  2.1 -    4.1 KB:  '/
+    data bin(11)  /'  4.1 -    8.2 KB:  '/
+    data bin(12)  /'  8.2 -   16.4 KB:  '/
+    data bin(13)  /' 16.4 -   32.8 KB:  '/
+    data bin(14)  /' 32.8 -   65.5 KB:  '/
+    data bin(15)  /' 65.5 -  131.1 KB:  '/
+    data bin(16)  /'131.1 -  262.1 KB:  '/
+    data bin(17)  /'262.1 -  524.3 KB:  '/
+    data bin(18)  /'524.3 - 1048.6 KB:  '/
+    data bin(19)  /'  1.0 -    2.1 MB:  '/
+    data bin(20)  /' >2.1          MB:  '/
+
+    if( .NOT.ANY(clocks(1:clock_num)%detailed) )return
+    write( filename,'(a,i4.4)' )'mpp_clock.out.', pe
+
+    SD_UNIT = get_unit()
+    open(SD_UNIT,file=trim(filename),form='formatted')
+
+    COMM_TYPE: do ct = 1,clock_num
+
+      if( .NOT.clocks(ct)%detailed )cycle
+      write(SD_UNIT,*) &
+          clock_summary(ct)%name(1:15),' Communication Data for PE ',pe
+
+      write(SD_UNIT,*) ' '
+      write(SD_UNIT,*) ' '
+
+      total_time_all = 0.0
+      EVENT_TYPE: do k = 1,MAX_EVENT_TYPES-1
+
+        if(clock_summary(ct)%event(k)%total_time == 0.0)cycle
+
+        total_time = clock_summary(ct)%event(k)%total_time
+        total_time_all = total_time_all + total_time
+        total_data = clock_summary(ct)%event(k)%total_data
+        total_calls = clock_summary(ct)%event(k)%total_cnts
+
+        write(SD_UNIT,1000) clock_summary(ct)%event(k)%name(1:9) // ':'
+
+        write(SD_UNIT,1001) 'Total Data: ',total_data*1.0e-6, &
+                            'MB; Total Time: ', total_time, &
+                            'secs; Total Calls: ',total_calls
+
+        write(SD_UNIT,*) ' '
+        write(SD_UNIT,1002) '     Bin            Counts      Avg Size        Eff B/W'
+        write(SD_UNIT,*) ' '
+
+        BIN_LOOP: do j=1,MAX_BINS
+
+          if(clock_summary(ct)%event(k)%msg_size_cnts(j)==0)cycle
+
+          if(j<=8)then
+            s = 1.0
+            u = ' B'
+          elseif(j<=18)then
+            s = 1.0e-3
+            u = 'KB'
+          else
+            s = 1.0e-6
+            u = 'MB'
+          endif
+
+          msg_cnt = clock_summary(ct)%event(k)%msg_size_cnts(j)
+          msg_size = &
+            s*(clock_summary(ct)%event(k)%msg_size_sums(j)/real(msg_cnt))
+          eff_BW = (1.0e-6)*( clock_summary(ct)%event(k)%msg_size_sums(j) / &
+                                  clock_summary(ct)%event(k)%msg_time_sums(j) )
+
+          write(SD_UNIT,1003) bin(j),msg_cnt,msg_size,u,eff_BW
+
+        end do BIN_LOOP
+
+        write(SD_UNIT,*) ' '
+        write(SD_UNIT,*) ' '
+      end do EVENT_TYPE
+
+   ! "Data-less" WAIT
+
+      if(clock_summary(ct)%event(MAX_EVENT_TYPES)%total_time>0.0)then
+
+        total_time = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_time
+        total_time_all = total_time_all + total_time
+        total_calls = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_cnts
+
+        write(SD_UNIT,1000) clock_summary(ct)%event(MAX_EVENT_TYPES)%name(1:9) // ':'
+
+        write(SD_UNIT,1004) 'Total Calls: ',total_calls,'; Total Time: ', &
+                             total_time,'secs'
+
+      endif
+
+      write(SD_UNIT,*) ' '
+      write(SD_UNIT,1005) 'Total communication time spent for ' // &
+                      clock_summary(ct)%name(1:9) // ': ',total_time_all,'secs'
+      write(SD_UNIT,*) ' '
+      write(SD_UNIT,*) ' '
+      write(SD_UNIT,*) ' '
+
+    end do COMM_TYPE
+
+    close(SD_UNIT)
+
+1000  format(a)
+1001  format(a,f8.2,a,f8.2,a,i6)
+1002  format(a)
+1003  format(a,i6,'    ','  ',f6.1,a,'    ',f7.3,'MB/sec')
+1004  format(a,i8,a,f9.2,a)
+1005  format(a,f9.2,a)
+    return
+  end subroutine dump_clock_summary
+
+      integer function get_unit()
+        implicit none
+
+        integer,save :: i
+        logical :: l_open
+
+        i = 10
+        do i=10,99
+           inquire(unit=i,opened=l_open)
+           if(.not.l_open)exit
+        end do
+
+        if(i==100)then
+            call mpp_error(FATAL,'Unable to get I/O unit')
+        else
+            get_unit = i
+        endif
+
+        return
+      end function get_unit
+
+  subroutine sum_clock_data()
+    implicit none
+
+    integer :: i,j,k,ct,event_size,event_cnt
+    real    :: msg_time
+
+    CLOCK_TYPE: do ct=1,clock_num
+      if( .NOT.clocks(ct)%detailed )cycle
+      EVENT_TYPE: do j=1,MAX_EVENT_TYPES-1
+        event_cnt = clocks(ct)%events(j)%calls
+        EVENT_SUMMARY: do i=1,event_cnt
+
+        clock_summary(ct)%event(j)%total_cnts = &
+              clock_summary(ct)%event(j)%total_cnts + 1
+
+        event_size = clocks(ct)%events(j)%bytes(i)
+
+        k = find_bin(event_size)
+
+        clock_summary(ct)%event(j)%msg_size_cnts(k) = &
+              clock_summary(ct)%event(j)%msg_size_cnts(k) + 1
+
+        clock_summary(ct)%event(j)%msg_size_sums(k) = &
+              clock_summary(ct)%event(j)%msg_size_sums(k) &
+            + clocks(ct)%events(j)%bytes(i)
+
+        clock_summary(ct)%event(j)%total_data = &
+              clock_summary(ct)%event(j)%total_data &
+            + clocks(ct)%events(j)%bytes(i)
+
+        msg_time = clocks(ct)%events(j)%ticks(i)
+        msg_time = tick_rate * real( clocks(ct)%events(j)%ticks(i) )
+
+        clock_summary(ct)%event(j)%msg_time_sums(k) = &
+              clock_summary(ct)%event(j)%msg_time_sums(k) + msg_time
+
+        clock_summary(ct)%event(j)%total_time = &
+              clock_summary(ct)%event(j)%total_time + msg_time
+
+        end do EVENT_SUMMARY
+      end do EVENT_TYPE
+
+      j = MAX_EVENT_TYPES ! WAITs
+           ! "msg_size_cnts" doesn't really mean anything for WAIT
+           ! but position will be used to store number of counts for now.
+
+      event_cnt = clocks(ct)%events(j)%calls
+      clock_summary(ct)%event(j)%msg_size_cnts(1) = event_cnt
+      clock_summary(ct)%event(j)%total_cnts       = event_cnt
+
+      msg_time = tick_rate * real( sum ( clocks(ct)%events(j)%ticks(1:event_cnt) ) )
+      clock_summary(ct)%event(j)%msg_time_sums(1) = &
+              clock_summary(ct)%event(j)%msg_time_sums(1) + msg_time
+
+      clock_summary(ct)%event(j)%total_time = clock_summary(ct)%event(j)%msg_time_sums(1)
+
+    end do CLOCK_TYPE
+
+    return
+    contains
+      integer function find_bin(event_size)
+        implicit none
+
+        integer,intent(in) :: event_size
+        integer :: k,msg_size
+
+        msg_size = 8
+        k = 1
+        do while(event_size>msg_size .and. k<MAX_BINS)
+           k = k+1
+           msg_size = msg_size*2
+        end do
+        find_bin = k
+        return
+      end function find_bin
+
+  end subroutine sum_clock_data
+
+  subroutine clock_init(id,name,flags)
+    integer, intent(in) :: id
+    character(len=*), intent(in) :: name
+    integer, intent(in), optional :: flags
+    integer :: i
+
+    clocks(id)%name = name
+    clocks(id)%tick = 0
+    clocks(id)%total_ticks = 0
+    clocks(id)%sync_on_begin = .FALSE.
+    clocks(id)%detailed      = .FALSE.
+    clocks(id)%peset_num = 0
+    if( PRESENT(flags) )then
+        if( BTEST(flags,0) )clocks(id)%sync_on_begin = .TRUE.
+        if( BTEST(flags,1) )clocks(id)%detailed      = .TRUE.
+    end if
+    if( clocks(id)%detailed )then
+        allocate( clocks(id)%events(MAX_EVENT_TYPES) )
+        clocks(id)%events(EVENT_ALLREDUCE)%name = 'ALLREDUCE'
+        clocks(id)%events(EVENT_BROADCAST)%name = 'BROADCAST'
+        clocks(id)%events(EVENT_RECV)%name = 'RECV'
+        clocks(id)%events(EVENT_SEND)%name = 'SEND'
+        clocks(id)%events(EVENT_WAIT)%name = 'WAIT'
+        do i=1,MAX_EVENT_TYPES
+           clocks(id)%events(i)%ticks(:) = 0
+           clocks(id)%events(i)%bytes(:) = 0
+           clocks(id)%events(i)%calls = 0
+        end do
+        clock_summary(id)%name = name
+        clock_summary(id)%event(EVENT_ALLREDUCE)%name = 'ALLREDUCE'
+        clock_summary(id)%event(EVENT_BROADCAST)%name = 'BROADCAST'
+        clock_summary(id)%event(EVENT_RECV)%name = 'RECV'
+        clock_summary(id)%event(EVENT_SEND)%name = 'SEND'
+        clock_summary(id)%event(EVENT_WAIT)%name = 'WAIT'
+        do i=1,MAX_EVENT_TYPES
+           clock_summary(id)%event(i)%msg_size_sums(:) = 0.0
+           clock_summary(id)%event(i)%msg_time_sums(:) = 0.0
+           clock_summary(id)%event(i)%total_data = 0.0
+           clock_summary(id)%event(i)%total_time = 0.0
+           clock_summary(id)%event(i)%msg_size_cnts(:) = 0
+           clock_summary(id)%event(i)%total_cnts = 0
+        end do
+    end if
+    return
+  end subroutine clock_init
+
+#ifdef __sgi
+    subroutine system_clock_sgi( count, count_rate, count_max )
+!mimics F90 SYSTEM_CLOCK intrinsic
+      integer(LONG_KIND), intent(out), optional :: count, count_rate, count_max
+      integer(LONG_KIND) :: sgi_tick, sgi_ticks_per_sec, sgi_max_tick
+!sgi_max_tick currently returns 64
+!count must return a number between 0 and count_max
+      integer(LONG_KIND), save :: maxtick=0
+      if( maxtick.EQ.0 )then
+          maxtick = sgi_max_tick() !actually reports #bits in maxtick
+          if( maxtick.LT.BIT_SIZE(maxtick) )then
+              maxtick = 2**maxtick
+          else
+              maxtick = huge(maxtick)
+          end if
+      end if
+      if( PRESENT(count) )then
+          count = modulo( sgi_tick()-tick0, maxtick )
+!          count = sgi_tick()
+      end if
+      if( PRESENT(count_rate) )then
+          count_rate = sgi_ticks_per_sec()
+      end if
+      if( PRESENT(count_max) )then
+          count_max = maxtick-1
+      end if
+      return
+    end subroutine system_clock_sgi
+#endif
+
+#ifdef use_libMPI
+    subroutine system_clock_mpi( count, count_rate, count_max )
+!mimics F90 SYSTEM_CLOCK intrinsic
+       integer(LONG_KIND), intent(out), optional :: count, count_rate, count_max
+!count must return a number between 0 and count_max
+       integer(LONG_KIND), parameter :: maxtick=HUGE(count_max)
+       logical,           save       :: first_call = .true.
+       real(DOUBLE_KIND), save       :: count0  ! use to prevent integer overflow
+       if ( first_call ) count0 = MPI_WTime(); first_call = .false.
+       if( PRESENT(count) )then
+           count = (MPI_WTime()-count0)/MPI_WTick()
+       end if
+       if( PRESENT(count_rate) )then
+           count_rate = MPI_Wtick()**(-1)
+       end if
+       if( PRESENT(count_max) )then
+           count_max = maxtick-1
+       end if
+       return
+     end subroutine system_clock_mpi
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!                BASIC MESSAGE PASSING ROUTINE: mpp_transmit                  !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_TRANSMIT_ mpp_transmit_real8
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_real8_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_real8_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_real8_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_real8_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_real8_5d
+#define MPP_RECV_ mpp_recv_real8
+#define MPP_RECV_SCALAR_ mpp_recv_real8_scalar
+#define MPP_RECV_2D_ mpp_recv_real8_2d
+#define MPP_RECV_3D_ mpp_recv_real8_3d
+#define MPP_RECV_4D_ mpp_recv_real8_4d
+#define MPP_RECV_5D_ mpp_recv_real8_5d
+#define MPP_SEND_ mpp_send_real8
+#define MPP_SEND_SCALAR_ mpp_send_real8_scalar
+#define MPP_SEND_2D_ mpp_send_real8_2d
+#define MPP_SEND_3D_ mpp_send_real8_3d
+#define MPP_SEND_4D_ mpp_send_real8_4d
+#define MPP_SEND_5D_ mpp_send_real8_5d
+#define MPP_BROADCAST_ mpp_broadcast_real8
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_real8_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_real8_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_real8_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_real8_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_real8_5d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_TYPE_BYTELEN_ 8
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_DOUBLE_PRECISION
+#else 
+#define MPI_TYPE_ MPI_REAL8
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST8
+#define SHMEM_GET_ SHMEM_GET8
+#include <mpp_transmit.h>
+
+#ifndef no_4byte_reals
+#define MPP_TRANSMIT_ mpp_transmit_real4
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_real4_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_real4_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_real4_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_real4_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_real4_5d
+#define MPP_RECV_ mpp_recv_real4
+#define MPP_RECV_SCALAR_ mpp_recv_real4_scalar
+#define MPP_RECV_2D_ mpp_recv_real4_2d
+#define MPP_RECV_3D_ mpp_recv_real4_3d
+#define MPP_RECV_4D_ mpp_recv_real4_4d
+#define MPP_RECV_5D_ mpp_recv_real4_5d
+#define MPP_SEND_ mpp_send_real4
+#define MPP_SEND_SCALAR_ mpp_send_real4_scalar
+#define MPP_SEND_2D_ mpp_send_real4_2d
+#define MPP_SEND_3D_ mpp_send_real4_3d
+#define MPP_SEND_4D_ mpp_send_real4_4d
+#define MPP_SEND_5D_ mpp_send_real4_5d
+#define MPP_BROADCAST_ mpp_broadcast_real4
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_real4_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_real4_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_real4_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_real4_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_real4_5d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_TYPE_BYTELEN_ 4
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_REAL
+#else
+#define MPI_TYPE_ MPI_REAL4
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST4
+#define SHMEM_GET_ SHMEM_GET4
+#include <mpp_transmit.h>
+#endif
+
+#define MPP_TRANSMIT_ mpp_transmit_cmplx8
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_cmplx8_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_cmplx8_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_cmplx8_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_cmplx8_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_cmplx8_5d
+#define MPP_RECV_ mpp_recv_cmplx8
+#define MPP_RECV_SCALAR_ mpp_recv_cmplx8_scalar
+#define MPP_RECV_2D_ mpp_recv_cmplx8_2d
+#define MPP_RECV_3D_ mpp_recv_cmplx8_3d
+#define MPP_RECV_4D_ mpp_recv_cmplx8_4d
+#define MPP_RECV_5D_ mpp_recv_cmplx8_5d
+#define MPP_SEND_ mpp_send_cmplx8
+#define MPP_SEND_SCALAR_ mpp_send_cmplx8_scalar
+#define MPP_SEND_2D_ mpp_send_cmplx8_2d
+#define MPP_SEND_3D_ mpp_send_cmplx8_3d
+#define MPP_SEND_4D_ mpp_send_cmplx8_4d
+#define MPP_SEND_5D_ mpp_send_cmplx8_5d
+#define MPP_BROADCAST_ mpp_broadcast_cmplx8
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_cmplx8_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_cmplx8_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_cmplx8_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_cmplx8_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_cmplx8_5d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_TYPE_BYTELEN_ 16
+#define MPI_TYPE_ MPI_DOUBLE_COMPLEX
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST8
+#define SHMEM_GET_ SHMEM_GET128
+#include <mpp_transmit.h>
+
+#ifndef no_4byte_cmplx
+#define MPP_TRANSMIT_ mpp_transmit_cmplx4
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_cmplx4_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_cmplx4_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_cmplx4_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_cmplx4_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_cmplx4_5d
+#define MPP_RECV_ mpp_recv_cmplx4
+#define MPP_RECV_SCALAR_ mpp_recv_cmplx4_scalar
+#define MPP_RECV_2D_ mpp_recv_cmplx4_2d
+#define MPP_RECV_3D_ mpp_recv_cmplx4_3d
+#define MPP_RECV_4D_ mpp_recv_cmplx4_4d
+#define MPP_RECV_5D_ mpp_recv_cmplx4_5d
+#define MPP_SEND_ mpp_send_cmplx4
+#define MPP_SEND_SCALAR_ mpp_send_cmplx4_scalar
+#define MPP_SEND_2D_ mpp_send_cmplx4_2d
+#define MPP_SEND_3D_ mpp_send_cmplx4_3d
+#define MPP_SEND_4D_ mpp_send_cmplx4_4d
+#define MPP_SEND_5D_ mpp_send_cmplx4_5d
+#define MPP_BROADCAST_ mpp_broadcast_cmplx4
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_cmplx4_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_cmplx4_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_cmplx4_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_cmplx4_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_cmplx4_5d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_TYPE_BYTELEN_ 8
+#define MPI_TYPE_ MPI_COMPLEX
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST4
+#define SHMEM_GET_ SHMEM_GET64
+#include <mpp_transmit.h>
+#endif
+
+#ifndef no_8byte_integers
+#define MPP_TRANSMIT_ mpp_transmit_int8
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_int8_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_int8_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_int8_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_int8_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_int8_5d
+#define MPP_RECV_ mpp_recv_int8
+#define MPP_RECV_SCALAR_ mpp_recv_int8_scalar
+#define MPP_RECV_2D_ mpp_recv_int8_2d
+#define MPP_RECV_3D_ mpp_recv_int8_3d
+#define MPP_RECV_4D_ mpp_recv_int8_4d
+#define MPP_RECV_5D_ mpp_recv_int8_5d
+#define MPP_SEND_ mpp_send_int8
+#define MPP_SEND_SCALAR_ mpp_send_int8_scalar
+#define MPP_SEND_2D_ mpp_send_int8_2d
+#define MPP_SEND_3D_ mpp_send_int8_3d
+#define MPP_SEND_4D_ mpp_send_int8_4d
+#define MPP_SEND_5D_ mpp_send_int8_5d
+#define MPP_BROADCAST_ mpp_broadcast_int8
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_int8_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_int8_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_int8_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_int8_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_int8_5d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_TYPE_BYTELEN_ 8
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER8
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST8
+#define SHMEM_GET_ SHMEM_GET8
+#include <mpp_transmit.h>
+#endif
+
+#define MPP_TRANSMIT_ mpp_transmit_int4
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_int4_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_int4_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_int4_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_int4_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_int4_5d
+#define MPP_RECV_ mpp_recv_int4
+#define MPP_RECV_SCALAR_ mpp_recv_int4_scalar
+#define MPP_RECV_2D_ mpp_recv_int4_2d
+#define MPP_RECV_3D_ mpp_recv_int4_3d
+#define MPP_RECV_4D_ mpp_recv_int4_4d
+#define MPP_RECV_5D_ mpp_recv_int4_5d
+#define MPP_SEND_ mpp_send_int4
+#define MPP_SEND_SCALAR_ mpp_send_int4_scalar
+#define MPP_SEND_2D_ mpp_send_int4_2d
+#define MPP_SEND_3D_ mpp_send_int4_3d
+#define MPP_SEND_4D_ mpp_send_int4_4d
+#define MPP_SEND_5D_ mpp_send_int4_5d
+#define MPP_BROADCAST_ mpp_broadcast_int4
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_int4_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_int4_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_int4_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_int4_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_int4_5d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_TYPE_BYTELEN_ 4
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER4
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST4
+#define SHMEM_GET_ SHMEM_GET4
+#include <mpp_transmit.h>
+
+#ifndef no_8byte_integers
+#define MPP_TRANSMIT_ mpp_transmit_logical8
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_logical8_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_logical8_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_logical8_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_logical8_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_logical8_5d
+#define MPP_RECV_ mpp_recv_logical8
+#define MPP_RECV_SCALAR_ mpp_recv_logical8_scalar
+#define MPP_RECV_2D_ mpp_recv_logical8_2d
+#define MPP_RECV_3D_ mpp_recv_logical8_3d
+#define MPP_RECV_4D_ mpp_recv_logical8_4d
+#define MPP_RECV_5D_ mpp_recv_logical8_5d
+#define MPP_SEND_ mpp_send_logical8
+#define MPP_SEND_SCALAR_ mpp_send_logical8_scalar
+#define MPP_SEND_2D_ mpp_send_logical8_2d
+#define MPP_SEND_3D_ mpp_send_logical8_3d
+#define MPP_SEND_4D_ mpp_send_logical8_4d
+#define MPP_SEND_5D_ mpp_send_logical8_5d
+#define MPP_BROADCAST_ mpp_broadcast_logical8
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_logical8_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_logical8_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_logical8_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_logical8_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_logical8_5d
+#define MPP_TYPE_ logical(LONG_KIND)
+#define MPP_TYPE_BYTELEN_ 8
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER8
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST8
+#define SHMEM_GET_ SHMEM_GET8
+#include <mpp_transmit.h>
+#endif
+
+#define MPP_TRANSMIT_ mpp_transmit_logical4
+#define MPP_TRANSMIT_SCALAR_ mpp_transmit_logical4_scalar
+#define MPP_TRANSMIT_2D_ mpp_transmit_logical4_2d
+#define MPP_TRANSMIT_3D_ mpp_transmit_logical4_3d
+#define MPP_TRANSMIT_4D_ mpp_transmit_logical4_4d
+#define MPP_TRANSMIT_5D_ mpp_transmit_logical4_5d
+#define MPP_RECV_ mpp_recv_logical4
+#define MPP_RECV_SCALAR_ mpp_recv_logical4_scalar
+#define MPP_RECV_2D_ mpp_recv_logical4_2d
+#define MPP_RECV_3D_ mpp_recv_logical4_3d
+#define MPP_RECV_4D_ mpp_recv_logical4_4d
+#define MPP_RECV_5D_ mpp_recv_logical4_5d
+#define MPP_SEND_ mpp_send_logical4
+#define MPP_SEND_SCALAR_ mpp_send_logical4_scalar
+#define MPP_SEND_2D_ mpp_send_logical4_2d
+#define MPP_SEND_3D_ mpp_send_logical4_3d
+#define MPP_SEND_4D_ mpp_send_logical4_4d
+#define MPP_SEND_5D_ mpp_send_logical4_5d
+#define MPP_BROADCAST_ mpp_broadcast_logical4
+#define MPP_BROADCAST_SCALAR_ mpp_broadcast_logical4_scalar
+#define MPP_BROADCAST_2D_ mpp_broadcast_logical4_2d
+#define MPP_BROADCAST_3D_ mpp_broadcast_logical4_3d
+#define MPP_BROADCAST_4D_ mpp_broadcast_logical4_4d
+#define MPP_BROADCAST_5D_ mpp_broadcast_logical4_5d
+#define MPP_TYPE_ logical(INT_KIND)
+#define MPP_TYPE_BYTELEN_ 4
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER4
+#endif
+#define SHMEM_BROADCAST_ SHMEM_BROADCAST4
+#define SHMEM_GET_ SHMEM_GET4
+#include <mpp_transmit.h>
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!            GLOBAL REDUCTION ROUTINES: mpp_max, mpp_sum, mpp_min             !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#define MPP_REDUCE_ mpp_max_real8
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define SHMEM_REDUCE_ SHMEM_REAL8_MAX_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_DOUBLE_PRECISION
+#else
+#define MPI_TYPE_ MPI_REAL8
+#endif
+#define MPI_REDUCE_ MPI_MAX
+#include <mpp_reduce.h>
+
+#define MPP_REDUCE_ mpp_max_real4
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define SHMEM_REDUCE_ SHMEM_REAL4_MAX_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_REAL
+#else
+#define MPI_TYPE_ MPI_REAL4
+#endif
+#define MPI_REDUCE_ MPI_MAX
+#include <mpp_reduce.h>
+
+#ifndef no_8byte_integers   
+#define MPP_REDUCE_ mpp_max_int8
+#define MPP_TYPE_ integer(LONG_KIND)
+#define SHMEM_REDUCE_ SHMEM_INT8_MAX_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER8
+#endif
+#define MPI_REDUCE_ MPI_MAX
+#include <mpp_reduce.h>
+#endif
+
+#define MPP_REDUCE_ mpp_max_int4
+#define MPP_TYPE_ integer(INT_KIND)
+#define SHMEM_REDUCE_ SHMEM_INT4_MAX_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER4
+#endif
+#define MPI_REDUCE_ MPI_MAX
+#include <mpp_reduce.h>
+
+#define MPP_REDUCE_ mpp_min_real8
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define SHMEM_REDUCE_ SHMEM_REAL8_MIN_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_DOUBLE_PRECISION
+#else
+#define MPI_TYPE_ MPI_REAL8
+#endif
+#define MPI_REDUCE_ MPI_MIN
+#include <mpp_reduce.h>
+
+#ifndef no_4byte_reals
+#define MPP_REDUCE_ mpp_min_real4
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define SHMEM_REDUCE_ SHMEM_REAL4_MIN_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_REAL
+#else
+#define MPI_TYPE_ MPI_REAL4
+#endif
+#define MPI_REDUCE_ MPI_MIN
+#include <mpp_reduce.h>
+#endif
+
+#ifndef no_8byte_integers   
+#define MPP_REDUCE_ mpp_min_int8
+#define MPP_TYPE_ integer(LONG_KIND)
+#define SHMEM_REDUCE_ SHMEM_INT8_MIN_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER8
+#endif
+#define MPI_REDUCE_ MPI_MIN
+#include <mpp_reduce.h>
+#endif
+
+#define MPP_REDUCE_ mpp_min_int4
+#define MPP_TYPE_ integer(INT_KIND)
+#define SHMEM_REDUCE_ SHMEM_INT4_MIN_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER4
+#endif
+#define MPI_REDUCE_ MPI_MIN
+#include <mpp_reduce.h>
+
+#define MPP_SUM_ mpp_sum_real8
+#define MPP_SUM_SCALAR_ mpp_sum_real8_scalar
+#define MPP_SUM_2D_ mpp_sum_real8_2d
+#define MPP_SUM_3D_ mpp_sum_real8_3d
+#define MPP_SUM_4D_ mpp_sum_real8_4d
+#define MPP_SUM_5D_ mpp_sum_real8_5d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define SHMEM_SUM_ SHMEM_REAL8_SUM_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_DOUBLE_PRECISION
+#else
+#define MPI_TYPE_ MPI_REAL8
+#endif
+#define MPP_TYPE_BYTELEN_ 8
+#include <mpp_sum.h>
+
+#ifndef no_4byte_reals
+#define MPP_SUM_ mpp_sum_real4
+#define MPP_SUM_SCALAR_ mpp_sum_real4_scalar
+#define MPP_SUM_2D_ mpp_sum_real4_2d
+#define MPP_SUM_3D_ mpp_sum_real4_3d
+#define MPP_SUM_4D_ mpp_sum_real4_4d
+#define MPP_SUM_5D_ mpp_sum_real4_5d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define SHMEM_SUM_ SHMEM_REAL4_SUM_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_REAL
+#else
+#define MPI_TYPE_ MPI_REAL4
+#endif
+#define MPP_TYPE_BYTELEN_ 4
+#include <mpp_sum.h>
+#endif
+
+#define MPP_SUM_ mpp_sum_cmplx8
+#define MPP_SUM_SCALAR_ mpp_sum_cmplx8_scalar
+#define MPP_SUM_2D_ mpp_sum_cmplx8_2d
+#define MPP_SUM_3D_ mpp_sum_cmplx8_3d
+#define MPP_SUM_4D_ mpp_sum_cmplx8_4d
+#define MPP_SUM_5D_ mpp_sum_cmplx8_5d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define SHMEM_SUM_ SHMEM_COMP8_SUM_TO_ALL
+#define MPI_TYPE_ MPI_DOUBLE_COMPLEX
+#define MPP_TYPE_BYTELEN_ 16
+#include <mpp_sum.h>
+
+#ifndef no_4byte_cmplx
+#define MPP_SUM_ mpp_sum_cmplx4
+#define MPP_SUM_SCALAR_ mpp_sum_cmplx4_scalar
+#define MPP_SUM_2D_ mpp_sum_cmplx4_2d
+#define MPP_SUM_3D_ mpp_sum_cmplx4_3d
+#define MPP_SUM_4D_ mpp_sum_cmplx4_4d
+#define MPP_SUM_5D_ mpp_sum_cmplx4_5d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define SHMEM_SUM_ SHMEM_COMP4_SUM_TO_ALL
+#define MPI_TYPE_ MPI_COMPLEX
+#define MPP_TYPE_BYTELEN_ 8
+#include <mpp_sum.h>
+#endif
+
+#ifndef no_8byte_integers
+#define MPP_SUM_ mpp_sum_int8
+#define MPP_SUM_SCALAR_ mpp_sum_int8_scalar
+#define MPP_SUM_2D_ mpp_sum_int8_2d
+#define MPP_SUM_3D_ mpp_sum_int8_3d
+#define MPP_SUM_4D_ mpp_sum_int8_4d
+#define MPP_SUM_5D_ mpp_sum_int8_5d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define SHMEM_SUM_ SHMEM_INT8_SUM_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER8
+#endif
+#define MPP_TYPE_BYTELEN_ 8
+#include <mpp_sum.h>
+#endif
+
+#define MPP_SUM_ mpp_sum_int4
+#define MPP_SUM_SCALAR_ mpp_sum_int4_scalar
+#define MPP_SUM_2D_ mpp_sum_int4_2d
+#define MPP_SUM_3D_ mpp_sum_int4_3d
+#define MPP_SUM_4D_ mpp_sum_int4_4d
+#define MPP_SUM_5D_ mpp_sum_int4_5d
+#define MPP_TYPE_ integer(INT_KIND)
+#define SHMEM_SUM_ SHMEM_INT4_SUM_TO_ALL
+#ifdef use_LAM_MPI
+#define MPI_TYPE_ MPI_INTEGER
+#else
+#define MPI_TYPE_ MPI_INTEGER4
+#endif
+#define MPP_TYPE_BYTELEN_ 4
+#include <mpp_sum.h>
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!           SYNCHRONIZATION ROUTINES: mpp_sync, mpp_sync_self                 !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_sync( pelist )
+!synchronize PEs in list
+      integer, intent(in), optional :: pelist(:)
+      integer :: n
+
+      call mpp_sync_self(pelist)
+
+      n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
+
+      if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#ifdef use_libSMA
+      if( n.EQ.world_peset_num )then
+          call SHMEM_BARRIER_ALL() !special call is faster
+      else
+          call SHMEM_BARRIER( peset(n)%start, peset(n)%log2stride, peset(n)%count, sync )
+      end if
+#endif
+#ifdef use_libMPI
+      call MPI_BARRIER( peset(n)%id, error )
+#endif
+      if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
+
+      return
+    end subroutine mpp_sync
+
+    subroutine mpp_sync_self( pelist )
+!this is to check if current PE's outstanding puts are complete
+!but we can't use shmem_fence because we are actually waiting for
+!a remote PE to complete its get
+      integer, intent(in), optional :: pelist(:)
+      integer :: i, m, n, stride
+
+      n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
+
+      if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
+#ifdef use_libSMA
+#ifdef _CRAYT90
+      call SHMEM_UDCFLUSH !invalidate data cache
+#endif
+#endif
+      do m = 1,peset(n)%count
+         i = peset(n)%list(m)
+#ifdef use_libSMA
+         call SHMEM_INT8_WAIT( status(i), MPP_WAIT ) !wait for status.NE.MPP_WAIT
+#endif
+#ifdef use_libMPI
+         if( request(i).NE.MPI_REQUEST_NULL )call MPI_WAIT( request(i), stat, error )
+#endif
+      end do
+      if( current_clock.NE.0 )call increment_current_clock(EVENT_WAIT)
+      return
+    end subroutine mpp_sync_self
+
+#ifdef use_libSMA
+!these local versions are written for grouping into shmem_integer_wait
+    subroutine shmem_int4_wait_local( ivar, cmp_value )
+!dir$ INLINEALWAYS shmem_int4_wait_local
+      integer(INT_KIND), intent(in) :: cmp_value
+      integer(INT_KIND), intent(inout) :: ivar
+      call SHMEM_INT4_WAIT( ivar, cmp_value )
+      return
+    end subroutine shmem_int4_wait_local
+    subroutine shmem_int8_wait_local( ivar, cmp_value )
+!dir$ INLINEALWAYS shmem_int8_wait_local
+      integer(LONG_KIND), intent(in) :: cmp_value
+      integer(LONG_KIND), intent(inout) :: ivar
+      call SHMEM_INT8_WAIT( ivar, cmp_value )
+      return
+    end subroutine shmem_int8_wait_local
+#endif
+      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                                                                             !
+!         MISCELLANEOUS UTILITIES: mpp_error, mpp_chksum, mpp_malloc          !
+!                                                                             !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    subroutine mpp_error_basic( errortype, errormsg )
+!a very basic error handler
+!uses ABORT and FLUSH calls, may need to use cpp to rename
+      integer, intent(in) :: errortype
+      character(len=*), intent(in), optional :: errormsg
+      character(len=128) :: text
+      logical :: opened
+      
+      if( .NOT.module_is_initialized )call ABORT()
+
+      select case( errortype )
+      case(NOTE)
+          text = 'NOTE'         !just FYI
+      case(WARNING)
+          text = 'WARNING'      !probable error
+      case(FATAL)
+          text = 'FATAL'        !fatal error
+      case default
+          text = 'WARNING: non-existent errortype (must be NOTE|WARNING|FATAL)'
+      end select
+
+      if( npes.GT.1 )write( text,'(a,i5)' )trim(text)//' from PE', pe !this is the mpp part
+      if( PRESENT(errormsg) )text = trim(text)//': '//trim(errormsg)
+
+      select case( errortype )
+      case(NOTE)
+          write( stdout(),'(a)' )trim(text)
+      case default
+          write( stderr(),'(/a/)' )trim(text)
+          if( errortype.EQ.FATAL .OR. warnings_are_fatal )then
+              call FLUSH(stdout())
+#ifdef sgi_mipspro
+!              call TRACE_BACK_STACK_AND_PRINT()
+#endif
+#ifdef use_libMPI
+#ifndef sgi_mipspro
+!the call to MPI_ABORT is not trapped by TotalView on sgi
+              call MPI_ABORT(  peset(0)%id, 1, error )
+#endif
+#endif
+              call ABORT()	!automatically calls traceback on Cray systems
+          end if
+      end select
+
+      error_state = errortype
+      return
+    end subroutine mpp_error_basic
+!overloads to mpp_error_basic
+    subroutine mpp_error_mesg( routine, errormsg, errortype )
+!support for error_mesg routine in FMS
+      character(len=*), intent(in) :: routine, errormsg
+      integer, intent(in) :: errortype
+      call mpp_error( errortype, trim(routine)//': '//trim(errormsg) )
+      return
+    end subroutine mpp_error_mesg
+    subroutine mpp_error_noargs()
+      call mpp_error(FATAL)
+    end subroutine mpp_error_noargs
+      
+    subroutine mpp_set_warn_level(flag)
+      integer, intent(in) :: flag
+
+      if( flag.EQ.WARNING )then
+          warnings_are_fatal = .FALSE.
+      else if( flag.EQ.FATAL )then
+          warnings_are_fatal = .TRUE.
+      else
+          call mpp_error( FATAL, 'MPP_SET_WARN_LEVEL: warning flag must be set to WARNING or FATAL.' )
+      end if
+      return
+    end subroutine mpp_set_warn_level
+
+    function mpp_error_state()
+      integer :: mpp_error_state
+      mpp_error_state = error_state
+      return
+    end function mpp_error_state
+
+#ifdef use_shmalloc
+    subroutine mpp_malloc( ptr, newlen, len )
+!routine to perform symmetric allocation:
+!this is required on the t3e/O2k for variables that will be non-local arguments
+!to a shmem call (see man intro_shmem(3F)).
+!newlen is the required allocation length for the pointer ptr
+!   len is the current allocation (0 if unallocated)
+      integer, intent(in) :: newlen
+      integer, intent(inout) :: len
+      real :: dummy
+      integer :: words_per_long
+      integer(LONG_KIND) :: long
+!argument ptr is a cray pointer, points to a dummy argument in this routine
+      pointer( ptr, dummy )
+!      integer(LONG_KIND) :: error_8
+
+      if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_MALLOC: You must first call mpp_init.' )
+!use existing allocation if it is enough
+      if( newlen.LE.len )return
+
+      call SHMEM_BARRIER_ALL()
+!if the pointer is already allocated, deallocate
+!      if( len.NE.0 )call SHPDEALLC( ptr, error_8, -1 ) !BWA: error_8 instead of error, see PV 682618 (fixed in mpt.1.3.0.1)
+      if( len.NE.0 )call SHPDEALLC( ptr, error, -1 )
+!allocate new length: assume that the array is KIND=8
+      words_per_long = size(transfer(long,word))
+      call SHPALLOC( ptr, newlen*words_per_long, error, -1 )
+      len = newlen
+      call SHMEM_BARRIER_ALL()
+
+      if( debug )then
+          call SYSTEM_CLOCK(tick)
+          write( stdout(),'(a,i18,a,i5,a,2i8,i16)' )'T=', tick, ' PE=', pe, ' MPP_MALLOC: len, newlen, ptr=', len, newlen, ptr
+      end if
+      return
+    end subroutine mpp_malloc
+#endif use_shmalloc
+
+    subroutine mpp_set_stack_size(n)
+!set the mpp_stack variable to be at least n LONG words long
+      integer, intent(in) :: n
+      character(len=8) :: text
+#ifdef use_shmalloc
+      call mpp_malloc( ptr_stack, n, mpp_stack_size )
+#else
+      if( n.GT.mpp_stack_size .AND. allocated(mpp_stack) )deallocate(mpp_stack)
+      if( .NOT.allocated(mpp_stack) )then
+          allocate( mpp_stack(n) )
+          mpp_stack_size = n
+      end if
+#endif
+      write( text,'(i8)' )n
+      if( pe.EQ.root_pe )call mpp_error( NOTE, 'MPP_SET_STACK_SIZE: stack size set to '//text//'.' )
+
+      return
+    end subroutine mpp_set_stack_size
+
+#ifndef no_8byte_integers
+#define MPP_CHKSUM_INT_ mpp_chksum_i8_1d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_RANK_  (:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i8_2d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_RANK_  (:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i8_3d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_RANK_  (:,:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i8_4d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_RANK_  (:,:,:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i8_5d
+#define MPP_TYPE_ integer(LONG_KIND)
+#define MPP_RANK_  (:,:,:,:,:)
+#include <mpp_chksum_int.h>
+#endif
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i4_1d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_RANK_  (:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i4_2d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_RANK_  (:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i4_3d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_RANK_  (:,:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i4_4d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_RANK_  (:,:,:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_INT_ mpp_chksum_i4_5d
+#define MPP_TYPE_ integer(INT_KIND)
+#define MPP_RANK_  (:,:,:,:,:)
+#include <mpp_chksum_int.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_0d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ !
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_1d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ (:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_2d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ (:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_3d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_4d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r8_5d
+#define MPP_TYPE_ real(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_0d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ !
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_1d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ (:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_2d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ (:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_3d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_4d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c8_5d
+#define MPP_TYPE_ complex(DOUBLE_KIND)
+#define MPP_RANK_ (:,:,:,:,:)
+#include <mpp_chksum.h>
+
+#ifndef no_4byte_reals
+!CAUTION: the r4 versions of these may produce
+!unpredictable results: I'm not sure what the result
+!of the TRANSFER() to integer(8) is from an odd number of real(4)s?
+!However the complex(4) will work, since it is guaranteed even.
+#define MPP_CHKSUM_ mpp_chksum_r4_0d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ !
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r4_1d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ (:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r4_2d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ (:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r4_3d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r4_4d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_r4_5d
+#define MPP_TYPE_ real(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:,:,:)
+#include <mpp_chksum.h>
+#endif
+
+#ifndef no_4byte_cmplx
+#define MPP_CHKSUM_ mpp_chksum_c4_0d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ !
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c4_1d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ (:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c4_2d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ (:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c4_3d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c4_4d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:,:)
+#include <mpp_chksum.h>
+
+#define MPP_CHKSUM_ mpp_chksum_c4_5d
+#define MPP_TYPE_ complex(FLOAT_KIND)
+#define MPP_RANK_ (:,:,:,:,:)
+#include <mpp_chksum.h>
+#endif
+
+  end module mpp_mod
+
+#ifdef test_mpp
+#ifdef SYSTEM_CLOCK
+#undef SYSTEM_CLOCK
+#endif
+  program test
+!test various aspects of mpp_mod
+#ifdef sgi_mipspro
+    use shmem_interface
+#endif
+    use mpp_mod
+    implicit none
+    integer :: pe, npes, root
+    integer, parameter :: n=1048576
+    real, allocatable, dimension(:) :: a, b, c
+    integer :: tick, tick0, ticks_per_sec, id
+    integer :: i, j, k, l, m
+    real :: dt
+
+    call mpp_init()
+    call mpp_set_stack_size(3145746)
+    pe = mpp_pe()
+    npes = mpp_npes()
+    root = mpp_root_pe()
+
+    call SYSTEM_CLOCK( count_rate=ticks_per_sec )
+    allocate( a(n), b(n) )
+    id = mpp_clock_id( 'Random number' )
+    call mpp_clock_begin(id)
+    call random_number(a)
+    call mpp_clock_end  (id)
+!time transmit, compare against shmem_put and get
+    if( pe.EQ.root )then
+        print *, 'Time mpp_transmit for various lengths...'
+#ifdef SGICRAY
+        print *, 'For comparison, times for shmem_get and shmem_put are also provided.'
+#endif
+        print *
+    end if
+    id = mpp_clock_id( 'mpp_transmit' )
+    call mpp_clock_begin(id)
+!timing is done for cyclical pass (more useful than ping-pong etc)
+    l = n
+    do while( l.GT.0 )
+!mpp_transmit
+       call mpp_sync()
+       call SYSTEM_CLOCK(tick0)
+       do i = 1,npes
+          call mpp_transmit( a, l, modulo(pe+npes-i,npes), b, l, modulo(pe+i,npes) )
+!          call mpp_sync_self( (/modulo(pe+npes-i,npes)/) )
+       end do
+       call mpp_sync()
+       call SYSTEM_CLOCK(tick)
+       dt = real(tick-tick0)/(npes*ticks_per_sec)
+       dt = max( dt, epsilon(dt) )
+       if( pe.EQ.root )write( stdout(),'(/a,i8,f13.6,f8.2)' )'MPP_TRANSMIT length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
+#ifdef SGICRAY
+!shmem_put
+       call mpp_sync()
+       call SYSTEM_CLOCK(tick0)
+       do i = 1,npes
+          call shmem_real_put( b, a, l, modulo(pe+1,npes) )
+       end do
+       call mpp_sync()
+       call SYSTEM_CLOCK(tick)
+       dt = real(tick-tick0)/(npes*ticks_per_sec)
+       dt = max( dt, epsilon(dt) )
+       if( pe.EQ.root )write( stdout(),'( a,i8,f13.6,f8.2)' )'SHMEM_PUT    length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
+!shmem_get
+       call mpp_sync()
+       call SYSTEM_CLOCK(tick0)
+       do i = 1,npes
+          call shmem_real_get( b, a, l, modulo(pe+1,npes) )
+       end do
+       call SYSTEM_CLOCK(tick)
+       dt = real(tick-tick0)/(npes*ticks_per_sec)
+       dt = max( dt, epsilon(dt) )
+       if( pe.EQ.root )write( stdout(),'( a,i8,f13.6,f8.2)' )'SHMEM_GET    length, time, bw(Mb/s)=', l, dt, l*8e-6/dt
+#endif
+       l = l/2
+    end do
+
+!test mpp_sum
+    if( pe.EQ.root )then
+        print '(/a)', 'Time mpp_sum...'
+    end if
+    a = real(pe+1)
+    call mpp_sync()
+    call SYSTEM_CLOCK(tick0)
+    call mpp_sum(a,n)
+    call SYSTEM_CLOCK(tick)
+    dt = real(tick-tick0)/ticks_per_sec
+    dt = max( dt, epsilon(dt) )
+    if( pe.EQ.root )write( stdout(),'(a,2i4,f9.1,i8,f13.6,f8.2/)' ) &
+         'mpp_sum: pe, npes, sum(pe+1), length, time, bw(Mb/s)=', pe, npes, a(1), n, dt, n*8e-6/dt
+    call mpp_clock_end(id)
+
+!test mpp_max
+    if( pe.EQ.root )then
+        print *
+        print *, 'Test mpp_max...'
+    end if
+    a = real(pe+1)
+    print *, 'pe,     pe+1 =', pe, a(1)
+    call mpp_max( a(1) )
+    print *, 'pe, max(pe+1)=', pe, a(1)
+
+!pelist check
+    call mpp_sync()
+    call flush(stdout())
+    if( npes.GE.2 )then
+        if( pe.EQ.root )print *, 'Test of pelists: bcast, sum and max using PEs 0...npes-2 (excluding last PE)'
+        call mpp_declare_pelist( (/(i,i=0,npes-2)/) )
+            
+        a = real(pe+1)
+        if( pe.NE.npes-1 )call mpp_broadcast( a, n, npes-2, (/(i,i=0,npes-2)/) )
+        print *, 'bcast(npes-1) from 0 to npes-2=', pe, a(1)
+        a = real(pe+1)
+        if( pe.NE.npes-1 )call mpp_sum( a, n, (/(i,i=0,npes-2)/) )
+        if( pe.EQ.root )print *, 'sum(pe+1) from 0 to npes-2=', a(1)
+        a = real(pe+1)
+        if( pe.NE.npes-1 )call mpp_max( a(1), (/(i,i=0,npes-2)/) )
+        if( pe.EQ.root )print *, 'max(pe+1) from 0 to npes-2=', a(1)
+    end if
+#ifdef use_CRI_pointers
+!test mpp_chksum
+    if( modulo(n,npes).EQ.0 )then  !only set up for even division
+        if( pe.EQ.root )call random_number(a)
+        call mpp_sync()
+        call mpp_transmit( a, n, ALL_PES, a, n, root )
+        m= n/npes
+        allocate( c(m) )
+        c = a(pe*m+1:pe*m+m)
+
+        if( pe.EQ.root )then
+            print *
+            print *, 'Test mpp_chksum...'
+            print *, 'This test shows that a whole array and a distributed array give identical checksums.'
+        end if
+        print *, 'chksum(a)=', mpp_chksum(a,(/pe/))
+        print *, 'chksum(c)=', mpp_chksum(c)
+    end if
+#endif
+    call mpp_exit()
+  end program test
+#endif
Index: CPL/oasis3/trunk/src/lib/mpp_io/src/nsclock.c
===================================================================
--- CPL/oasis3/trunk/src/lib/mpp_io/src/nsclock.c	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/mpp_io/src/nsclock.c	(revision 1677)
@@ -0,0 +1,38 @@
+#include <stdio.h>
+#include <time.h>
+
+#ifdef __sgi
+
+long delta_t=0;			// clock resolution in nanoseconds
+
+long sgi_ticks_per_sec_() {	// returns inverse clock resolution (1/sec)
+  struct timespec t;
+  clock_getres( CLOCK_SGI_CYCLE, &t );
+  delta_t = (long)t.tv_sec*1000000000 + (long)t.tv_nsec;
+  return 1000000000/delta_t;
+}
+
+long sgi_tick_() {		// returns current time in units of delta_t
+  struct timespec t;
+  if( delta_t==0 ) (void) sgi_ticks_per_sec_(); // initialize delta_t if needed
+  clock_gettime( CLOCK_SGI_CYCLE, &t );
+  return ( (long)t.tv_sec*1000000000+(long)t.tv_nsec )/delta_t;
+}
+
+long sgi_max_tick_() {		// clock rollover point is 2^max_tick
+#include <sys/syssgi.h>
+  return syssgi(SGI_CYCLECNTR_SIZE);
+}
+#endif
+
+#ifdef test_nsclock
+void main() {
+#ifdef __sgi
+  printf( "ticks per second=%li\n", sgi_ticks_per_sec_() );
+  printf( "delta_t=%li\n", delta_t );
+  printf( "max tick=%li\n", sgi_max_tick_() );
+#else
+  printf( "ticks per second=%i\n", CLOCKS_PER_SEC );
+#endif
+}
+#endif
Index: CPL/oasis3/trunk/src/lib/psmile/include/psmile_os.h
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/include/psmile_os.h	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/include/psmile_os.h	(revision 1677)
@@ -0,0 +1,23 @@
+#ifndef __PRISM_OS_INCLUDED
+
+#define __PRISM_OS_INCLUDED
+
+#undef __NO_4BYTE_REALS
+#undef __NO_4BYTE_CMPLX
+
+#ifdef __SXdbl4
+
+#define __NO_4BYTE_REALS
+#define __NO_4BYTE_CMPLX
+
+#endif
+
+#ifdef __crayx1
+
+#define  __NO_4BYTE_REALS
+#define  __NO_4BYTE_CMPLX
+#define  __no_8byte_integers
+
+#endif 
+
+#endif
Index: CPL/oasis3/trunk/src/lib/psmile/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/Makefile	(revision 1677)
@@ -0,0 +1,88 @@
+
+SRCS1	= $(shell ls ../../../../src/lib/psmile/src/*.F90)
+OBJS1	= $(patsubst ../../../../src/lib/psmile/src/%.F90, %.o, $(SRCS1))
+
+SRCS2 =  $(shell ls ../../../../src/lib/psmile/src/*.f90)
+OBJS2 =  $(patsubst ../../../../src/lib/psmile/src/%.f90, %.o, $(SRCS2))
+
+SRCS3 	= $(shell ls ../../../../src/lib/psmile/src/*.F)
+OBJS3 	= $(patsubst ../../../../src/lib/psmile/src/%.F, %.o, $(SRCS3))
+
+VPATH 	= ./:../../../../src/lib/psmile/src:\
+	     ../../../../src/lib/psmile/include:\
+             ../../../../src/lib/mpp_io/src:\
+             ../../../../src/lib/mpp_io/include
+
+LIBRARY = ../../../lib/libpsmile.${CHAN}.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS1) $(OBJS2) $(OBJS3) 
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS1) $(OBJS2) $(OBJS3)
+
+INCLS = -I../../../../src/lib/psmile/include \
+	-I../../../../src/lib/mpp_io/include
+
+INCLSC = -I../../../../src/lib/psmile/include \
+	-I../../../../src/lib/mpp_io/include
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(MPPFLAGS) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(MPPFLAGS) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(MPPFLAGS) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(MPPFLAGS) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# ALL dependencies ...
+#
+
+mod_psmile_date_and_time.o: mod_kinds_model.o
+mod_psmile_io_interfaces.o: mod_kinds_model.o
+mod_psmile_io.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o mpp_mod.o \
+	mpp_io_mod.o mpp_domains_mod.o mod_psmile_io_interfaces.o mod_psmile_date_and_time.o
+mpp_io_mod.o: mod_kinds_model.o mpp_mod.o mpp_domains_mod.o
+mpp_mod.o: mod_kinds_model.o os.h mpp_transmit.h mpp_reduce.h mpp_sum.h \
+	mpp_chksum_int.h mpp_chksum.h
+mpp_domains_mod.o: mod_kinds_model.o mpp_mod.o os.h mpp_update_domains2D.h \
+	mpp_global_reduce.h mpp_global_sum.h mpp_global_field.h
+mod_prism_proto.o: mod_kinds_model.o
+mod_comprism_proto.o: mod_kinds_model.o mod_prism_proto.o
+mod_prism_get_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	psmile_os.h
+mod_prism_put_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	write_file.o mathelp_psmile.o psmile_os.h
+prism_put_restart_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	write_file.o
+prism_put_inquire_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o
+mod_prism_def_partition_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o
+mod_prism_grids_writing: mod_kinds_model.o mod_comprism_proto.o
+prism_abort_proto.o: mod_comprism_proto.o
+prism_def_var_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o
+prism_enddef_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	mod_psmile_io_interfaces.o
+mod_prism_get_comm.o: mod_kinds_model.o mod_comprism_proto.o
+prism_get_localcomm_proto.o: mod_kinds_model.o mod_prism_proto.o \
+	mod_comprism_proto.o
+prism_init_comp_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	mod_psmile_io_interfaces.o
+prism_terminate_proto.o: mod_kinds_model.o mod_prism_proto.o mod_comprism_proto.o \
+	mod_psmile_io_interfaces.o
+errioipsl_psmile.o: mod_kinds_model.o
+mathelp_psmile.o: errioipsl_psmile.o stringop_psmile.o mod_kinds_model.o psmile_os.h
+
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/errioipsl_psmile.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/errioipsl_psmile.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/errioipsl_psmile.F90	(revision 1677)
@@ -0,0 +1,42 @@
+MODULE errioipsl_psmile
+!---------------------------------------------------------------------
+CONTAINS
+!=
+   SUBROUTINE histerr (plev, pcname, pstr1, pstr2, pstr3)
+!---------------------------------------------------------------------
+!- INPUT
+!- plev   : Category of message to be reported to the user
+!-          1 = Note to the user
+!-          2 = Warning to the user
+!-          3 = Fatal error
+!- pcname : Name of subroutine which has called histerr
+!- pstr1   
+!- pstr2  : String containing the explanations to the user
+!- pstr3
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   INTEGER (kind=ip_intwp_p) :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     WRITE(*,'("     ")')
+     WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(*,'(" --> ",a)') pstr1
+     WRITE(*,'(" --> ",a)') pstr2
+     WRITE(*,'(" --> ",a)') pstr3
+   ENDIF
+   IF (plev == 3) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!------------------------
+   END SUBROUTINE histerr
+!=
+!-------------------
+END MODULE errioipsl_psmile
Index: CPL/oasis3/trunk/src/lib/psmile/src/mathelp_psmile.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mathelp_psmile.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mathelp_psmile.F90	(revision 1677)
@@ -0,0 +1,2638 @@
+
+MODULE mathelp_psmile
+!---------------------------------------------------------------------
+!
+! Reiner Vogelsang, SGI, 27 April 2003
+! - Screening of 4 byte real interfaces in case a of dbl4 compilation.
+!   File has to be preprocessed with -D__SXdbl4.
+!
+!
+!---------------------------------------------------------------------
+#include "psmile_os.h"
+
+   USE errioipsl_psmile,ONLY : histerr
+   USE stringop_psmile
+!-
+   PRIVATE
+   PUBLIC :: mathop,moycum,trans_buff,buildop
+!-
+   INTERFACE buildop
+#ifndef __NO_4BYTE_REALS
+     MODULE PROCEDURE buildop_r4
+#endif
+     MODULE PROCEDURE buildop_r8
+  end INTERFACE
+
+   INTERFACE mathop
+#ifndef __NO_4BYTE_REALS
+     MODULE PROCEDURE mathop_r114
+#endif
+     MODULE PROCEDURE mathop_r118
+   END INTERFACE
+
+   INTERFACE moycum
+#ifndef __NO_4BYTE_REALS
+     MODULE PROCEDURE moycum_r4
+#endif
+     MODULE PROCEDURE moycum_r8
+  end INTERFACE
+   
+!-
+!- Variables used to detect and identify the operations
+!-
+   CHARACTER(LEN=80),SAVE :: &
+  &  seps='( ) , + - / * ^', ops = '+ - * / ^', mima = 'min max'
+   CHARACTER(LEN=250),SAVE :: &
+  &  funcs = 'sin cos tan asin acos atan exp log sqrt chs abs '&
+  & //'cels kelv deg rad gather scatter fill coll undef only ident'
+   CHARACTER(LEN=120),SAVE :: &
+  &  indexfu = 'gather, scatter, fill, coll, undef, only'
+!---------------------------------------------------------------------
+CONTAINS
+!=
+   SUBROUTINE buildop_r4 (str,ex_topps,topp,nbops_max, &
+  &                    missing_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+!- This subroutine decomposes the input string in the elementary
+!- functions which need to be applied to the vector of data.
+!- This vector is represented by X in the string.
+!- This subroutine is the driver of the decomposition and gets
+!- the time operation but then call decoop for the other operations
+!-
+!- INPUT
+!-
+!- str      : String containing the operations
+!- ex_toops : The time operations that can be expected within the string
+!-
+!- OUTPUT
+!-
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 ::str
+   CHARACTER*(*) :: ex_topps
+   CHARACTER*7 :: topp
+   INTEGER (kind=ip_intwp_p) :: nbops_max,nbops
+   CHARACTER*7 :: opps(nbops_max)
+   REAL (kind=ip_single_p) :: scal(nbops_max),missing_val
+!-
+   CHARACTER*80 :: new_str
+   INTEGER (kind=ip_intwp_p) :: leng,ind_opb,ind_clb
+!-
+   LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+   IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning'
+!-
+   leng = LEN_TRIM(str)
+   IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
+     str = str(2:leng-1)
+     leng = leng-2
+   ENDIF
+!-
+   IF (check) &
+  &  WRITE(*,*) 'buildop : Starting to test the various options'
+!-
+   IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN
+     IF (check) WRITE(*,*) 'buildop : Time operation only'
+     nbops = 0
+     topp = str(1:leng)
+   ELSE
+     IF (check) WRITE(*,*) 'buildop : Time operation and something else'
+!---
+     ind_opb = INDEX(str(1:leng),'(')
+     IF (ind_opb > 0) THEN
+       IF ( INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN
+         IF (check) WRITE(*,'(2a)') &
+                  &  ' buildop : Extract time operation from : ',str
+         topp = str(1:ind_opb-1)
+         ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.)
+         new_str = str(ind_opb+1:ind_clb-1)
+         IF (check) WRITE(*,'(2a,2I3)') &
+                  &  ' buildop : Call decoop ',new_str,ind_opb,ind_clb
+         CALL decoop_r4 (new_str,nbops_max,missing_val,opps,scal,nbops)
+       ELSE
+         CALL histerr(3,'buildop','time opperation does not exist',str(1:ind_opb-1),' ')
+       ENDIF
+     ELSE
+       CALL histerr(3,'buildop','some long opperation exists but wihout parenthesis',str(1:leng),' ')
+     ENDIF
+   ENDIF
+!-
+   IF (check) THEN
+     DO leng=1,nbops
+       WRITE(*,*) 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng)
+     ENDDO
+   ENDIF
+!------------------------
+ END SUBROUTINE buildop_r4
+!=
+   SUBROUTINE buildop_r8 (str,ex_topps,topp,nbops_max, &
+  &                    missing_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+!- This subroutine decomposes the input string in the elementary
+!- functions which need to be applied to the vector of data.
+!- This vector is represented by X in the string.
+!- This subroutine is the driver of the decomposition and gets
+!- the time operation but then call decoop for the other operations
+!-
+!- INPUT
+!-
+!- str      : String containing the operations
+!- ex_toops : The time operations that can be expected within the string
+!-
+!- OUTPUT
+!-
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 ::str
+   CHARACTER*(*) :: ex_topps
+   CHARACTER*7 :: topp
+   INTEGER (kind=ip_intwp_p) :: nbops_max,nbops
+   CHARACTER*7 :: opps(nbops_max)
+   REAL (kind=ip_double_p) :: scal(nbops_max),missing_val
+!-
+   CHARACTER*80 :: new_str
+   INTEGER (kind=ip_intwp_p) :: leng,ind_opb,ind_clb
+!-
+   LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+   IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning'
+!-
+   leng = LEN_TRIM(str)
+   IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
+     str = str(2:leng-1)
+     leng = leng-2
+   ENDIF
+!-
+   IF (check) &
+  &  WRITE(*,*) 'buildop : Starting to test the various options'
+!-
+   IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN
+     IF (check) WRITE(*,*) 'buildop : Time operation only'
+     nbops = 0
+     topp = str(1:leng)
+   ELSE
+     IF (check) WRITE(*,*) 'buildop : Time operation and something else'
+!---
+     ind_opb = INDEX(str(1:leng),'(')
+     IF (ind_opb > 0) THEN
+       IF ( INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN
+         IF (check) WRITE(*,'(2a)') &
+                  &  ' buildop : Extract time operation from : ',str
+         topp = str(1:ind_opb-1)
+         ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.)
+         new_str = str(ind_opb+1:ind_clb-1)
+         IF (check) WRITE(*,'(2a,2I3)') &
+                  &  ' buildop : Call decoop ',new_str,ind_opb,ind_clb
+         CALL decoop_r8 (new_str,nbops_max,missing_val,opps,scal,nbops)
+       ELSE
+         CALL histerr(3,'buildop','time opperation does not exist',str(1:ind_opb-1),' ')
+       ENDIF
+     ELSE
+       CALL histerr(3,'buildop','some long opperation exists but wihout parenthesis',str(1:leng),' ')
+     ENDIF
+   ENDIF
+!-
+   IF (check) THEN
+     DO leng=1,nbops
+       WRITE(*,*) 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng)
+     ENDDO
+   ENDIF
+!------------------------
+ END SUBROUTINE buildop_r8
+!=
+   SUBROUTINE decoop_r4 (pstr,nbops_max,missing_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 :: pstr
+   INTEGER (kind=ip_intwp_p) :: nbops_max,nbops
+   CHARACTER*7 :: opps(nbops_max)
+   REAL (kind=ip_single_p) :: scal(nbops_max),missing_val
+!-
+   CHARACTER*1 :: f_char(2),s_char(2)
+   INTEGER (kind=ip_intwp_p) :: nbsep,f_pos(2),s_pos(2)
+   CHARACTER*20 :: opp_str,scal_str
+   CHARACTER*80 :: str
+   INTEGER (kind=ip_intwp_p) :: xpos,leng,ppos,epos,int_tmp
+   CHARACTER*3 :: tl,dl
+   CHARACTER*10 :: fmt
+!-
+   LOGICAL :: check = .FALSE.,prio
+!---------------------------------------------------------------------
+   IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr
+!-
+   nbops = 0
+   str = pstr
+!-
+   CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
+   IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep
+   DO WHILE (nbsep > 0)
+     xpos = INDEX(str,'X')
+     leng = LEN_TRIM(str)
+     nbops = nbops+1
+!---
+     IF (check) THEN
+       WRITE(*,*) 'decoop : str -->',str(1:leng)
+       WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2)
+       WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2)
+     ENDIF
+!---
+     IF (nbops > nbops_max-1) THEN
+       CALL histerr(3,'decoop','Expression too complex',str,' ')
+     ENDIF
+!---
+     IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng)
+!---
+!--- Start the analysis of the syntax. 3 types of constructs
+!--- are recognized.  They are scanned sequentialy
+!---
+     IF (nbsep == 1) THEN
+       IF (check) WRITE(*,*) 'decoop : Only one operation'
+       IF (INDEX(ops,f_char(1)) > 0) THEN
+!-------
+!------- Type : scal+X
+!-------
+         IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+           opp_str = f_char(1)//'I'
+         ELSE
+           opp_str = f_char(1)
+         ENDIF
+         scal_str = str(s_pos(1)+1:f_pos(1)-1)
+         str = 'X'
+       ELSE IF (INDEX(ops,f_char(2)) > 0) THEN
+!-------
+!------- Type : X+scal
+!-------
+         opp_str = f_char(2)
+         scal_str = str(f_pos(2)+1:s_pos(2)-1)
+         str = 'X'
+       ELSE
+         CALL histerr(3,'decoop','Unknown operations of type X+scal',f_char(1),pstr)
+       ENDIF
+     ELSE
+       IF (check) WRITE(*,*) 'decoop : More complex operation'
+       IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN
+!-------
+!------- Type : sin(X)
+!-------
+         opp_str = str(s_pos(1)+1:f_pos(1)-1)
+         scal_str = '?'
+         str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng)
+       ELSE IF (    (f_char(1) == '(' .AND. f_char(2) == ',')&
+      &         .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN
+!-------
+!------- Type : max(X,scal) or max(scal,X)
+!-------
+         IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN
+!---------
+!--------- Type : max(X,scal)
+!---------
+           opp_str = str(f_pos(1)-3:f_pos(1)-1)
+           scal_str = str(f_pos(2)+1:s_pos(2)-1)
+           str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng)
+         ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN
+!---------
+!--------- Type : max(scal,X)
+!---------
+           opp_str = str(s_pos(1)-3:s_pos(1)-1)
+           scal_str = str(s_pos(1)+1:f_pos(1)-1)
+           str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng)
+         ELSE
+           CALL histerr(3,'decoop','Syntax error 1',str,' ')
+         ENDIF
+       ELSE
+         prio = (f_char(2) == '*').OR.(f_char(2) == '^')
+         IF (     (INDEX(ops,f_char(1)) > 0) &
+        &    .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN
+!---------
+!--------- Type : ... scal+X ...
+!---------
+           IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+             opp_str = f_char(1)//'I'
+           ELSE
+             opp_str = f_char(1)
+           ENDIF
+           scal_str = str(s_pos(1)+1:f_pos(1)-1)
+           str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng)
+         ELSE IF (     (INDEX(ops,f_char(2)) > 0) &
+        &         .AND.(f_pos(2)-xpos == 1) ) THEN
+!---------
+!--------- Type : ... X+scal ...
+!---------
+           opp_str = f_char(2)
+           scal_str = str(f_pos(2)+1:s_pos(2)-1)
+           str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng)
+         ELSE
+           CALL histerr(3,'decoop','Syntax error 2',str,' ')
+         ENDIF
+       ENDIF
+     ENDIF
+!---
+     IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',str(1:LEN_TRIM(str))
+!-----
+!----- Now that the different components of the operation are identified
+!----- we transform them into what is going to be used in the program
+!-----
+     IF (INDEX(scal_str,'?') > 0) THEN
+       IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN
+         opps(nbops) = opp_str(1:LEN_TRIM(opp_str))
+         scal(nbops) =  missing_val
+       ELSE
+         CALL histerr(3,'decoop','Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ')
+       ENDIF
+     ELSE
+       leng = LEN_TRIM(opp_str)
+       IF (INDEX(mima,opp_str(1:leng)) > 0) THEN
+         opps(nbops) = 'fu'//opp_str(1:leng)
+       ELSE
+         IF (INDEX(opp_str(1:leng),'+') > 0) THEN
+           opps(nbops) = 'add'
+         ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN
+           opps(nbops) = 'subi'
+         ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN
+           opps(nbops) = 'sub'
+         ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN
+           opps(nbops) = 'mult'
+         ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN
+           opps(nbops) = 'div'
+         ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN
+           opps(nbops) = 'divi'
+         ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN
+           opps(nbops) = 'power'
+         ELSE
+           CALL histerr(3,'decoop','Unknown operation',opp_str(1:leng),' ')
+         ENDIF
+       ENDIF
+!-----
+       leng = LEN_TRIM(scal_str)
+       ppos = INDEX(scal_str,'.')
+       epos = INDEX(scal_str,'e')
+       IF (epos == 0) epos = INDEX(scal_str,'E')
+!-----
+!----- Try to catch a few errors
+!-----
+       IF (INDEX(ops,scal_str) > 0) THEN
+         CALL histerr(3,'decoop','Strange scalar you have here ',scal_str,pstr)
+       ENDIF
+       IF (epos > 0) THEN
+         WRITE(tl,'(I3.3)') leng
+         WRITE(dl,'(I3.3)') epos-ppos-1
+         fmt='(e'//tl//'.'//dl//')'
+         READ(scal_str,fmt) scal(nbops)
+       ELSE IF (ppos > 0) THEN
+         WRITE(tl,'(I3.3)') leng
+         WRITE(dl,'(I3.3)') leng-ppos
+         fmt='(f'//tl//'.'//dl//')'
+         READ(scal_str,fmt) scal(nbops)
+       ELSE
+         WRITE(tl,'(I3.3)') leng
+         fmt = '(I'//tl//')'
+         READ(scal_str,fmt) int_tmp
+         scal(nbops) = REAL(int_tmp, kind=ip_single_p)
+       ENDIF
+     ENDIF
+     IF (check) WRITE(*,*) 'decoop : Finished interpretation'
+     CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos)
+   ENDDO
+!-----------------------
+ END SUBROUTINE decoop_r4
+!=
+   SUBROUTINE decoop_r8 (pstr,nbops_max,missing_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 :: pstr
+   INTEGER (kind=ip_intwp_p) :: nbops_max,nbops
+   CHARACTER*7 :: opps(nbops_max)
+   REAL (kind=ip_double_p) :: scal(nbops_max),missing_val
+!-
+   CHARACTER*1 :: f_char(2),s_char(2)
+   INTEGER (kind=ip_intwp_p) :: nbsep,f_pos(2),s_pos(2)
+   CHARACTER*20 :: opp_str,scal_str
+   CHARACTER*80 :: str
+   INTEGER (kind=ip_intwp_p) :: xpos,leng,ppos,epos,int_tmp
+   CHARACTER*3 :: tl,dl
+   CHARACTER*10 :: fmt
+!-
+   LOGICAL :: check = .FALSE.,prio
+!---------------------------------------------------------------------
+   IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr
+!-
+   nbops = 0
+   str = pstr
+!-
+   CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
+   IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep
+   DO WHILE (nbsep > 0)
+     xpos = INDEX(str,'X')
+     leng = LEN_TRIM(str)
+     nbops = nbops+1
+!---
+     IF (check) THEN
+       WRITE(*,*) 'decoop : str -->',str(1:leng)
+       WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2)
+       WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2)
+     ENDIF
+!---
+     IF (nbops > nbops_max-1) THEN
+       CALL histerr(3,'decoop','Expression too complex',str,' ')
+     ENDIF
+!---
+     IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng)
+!---
+!--- Start the analysis of the syntax. 3 types of constructs
+!--- are recognized.  They are scanned sequentialy
+!---
+     IF (nbsep == 1) THEN
+       IF (check) WRITE(*,*) 'decoop : Only one operation'
+       IF (INDEX(ops,f_char(1)) > 0) THEN
+!-------
+!------- Type : scal+X
+!-------
+         IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+           opp_str = f_char(1)//'I'
+         ELSE
+           opp_str = f_char(1)
+         ENDIF
+         scal_str = str(s_pos(1)+1:f_pos(1)-1)
+         str = 'X'
+       ELSE IF (INDEX(ops,f_char(2)) > 0) THEN
+!-------
+!------- Type : X+scal
+!-------
+         opp_str = f_char(2)
+         scal_str = str(f_pos(2)+1:s_pos(2)-1)
+         str = 'X'
+       ELSE
+         CALL histerr(3,'decoop','Unknown operations of type X+scal',f_char(1),pstr)
+       ENDIF
+     ELSE
+       IF (check) WRITE(*,*) 'decoop : More complex operation'
+       IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN
+!-------
+!------- Type : sin(X)
+!-------
+         opp_str = str(s_pos(1)+1:f_pos(1)-1)
+         scal_str = '?'
+         str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng)
+       ELSE IF (    (f_char(1) == '(' .AND. f_char(2) == ',')&
+      &         .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN
+!-------
+!------- Type : max(X,scal) or max(scal,X)
+!-------
+         IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN
+!---------
+!--------- Type : max(X,scal)
+!---------
+           opp_str = str(f_pos(1)-3:f_pos(1)-1)
+           scal_str = str(f_pos(2)+1:s_pos(2)-1)
+           str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng)
+         ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN
+!---------
+!--------- Type : max(scal,X)
+!---------
+           opp_str = str(s_pos(1)-3:s_pos(1)-1)
+           scal_str = str(s_pos(1)+1:f_pos(1)-1)
+           str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng)
+         ELSE
+           CALL histerr(3,'decoop','Syntax error 1',str,' ')
+         ENDIF
+       ELSE
+         prio = (f_char(2) == '*').OR.(f_char(2) == '^')
+         IF (     (INDEX(ops,f_char(1)) > 0) &
+        &    .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN
+!---------
+!--------- Type : ... scal+X ...
+!---------
+           IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+             opp_str = f_char(1)//'I'
+           ELSE
+             opp_str = f_char(1)
+           ENDIF
+           scal_str = str(s_pos(1)+1:f_pos(1)-1)
+           str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng)
+         ELSE IF (     (INDEX(ops,f_char(2)) > 0) &
+        &         .AND.(f_pos(2)-xpos == 1) ) THEN
+!---------
+!--------- Type : ... X+scal ...
+!---------
+           opp_str = f_char(2)
+           scal_str = str(f_pos(2)+1:s_pos(2)-1)
+           str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng)
+         ELSE
+           CALL histerr(3,'decoop','Syntax error 2',str,' ')
+         ENDIF
+       ENDIF
+     ENDIF
+!---
+     IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',str(1:LEN_TRIM(str))
+!-----
+!----- Now that the different components of the operation are identified
+!----- we transform them into what is going to be used in the program
+!-----
+     IF (INDEX(scal_str,'?') > 0) THEN
+       IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN
+         opps(nbops) = opp_str(1:LEN_TRIM(opp_str))
+         scal(nbops) =  missing_val
+       ELSE
+         CALL histerr(3,'decoop','Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ')
+       ENDIF
+     ELSE
+       leng = LEN_TRIM(opp_str)
+       IF (INDEX(mima,opp_str(1:leng)) > 0) THEN
+         opps(nbops) = 'fu'//opp_str(1:leng)
+       ELSE
+         IF (INDEX(opp_str(1:leng),'+') > 0) THEN
+           opps(nbops) = 'add'
+         ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN
+           opps(nbops) = 'subi'
+         ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN
+           opps(nbops) = 'sub'
+         ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN
+           opps(nbops) = 'mult'
+         ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN
+           opps(nbops) = 'div'
+         ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN
+           opps(nbops) = 'divi'
+         ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN
+           opps(nbops) = 'power'
+         ELSE
+           CALL histerr(3,'decoop','Unknown operation',opp_str(1:leng),' ')
+         ENDIF
+       ENDIF
+!-----
+       leng = LEN_TRIM(scal_str)
+       ppos = INDEX(scal_str,'.')
+       epos = INDEX(scal_str,'e')
+       IF (epos == 0) epos = INDEX(scal_str,'E')
+!-----
+!----- Try to catch a few errors
+!-----
+       IF (INDEX(ops,scal_str) > 0) THEN
+         CALL histerr(3,'decoop','Strange scalar you have here ',scal_str,pstr)
+       ENDIF
+       IF (epos > 0) THEN
+         WRITE(tl,'(I3.3)') leng
+         WRITE(dl,'(I3.3)') epos-ppos-1
+         fmt='(e'//tl//'.'//dl//')'
+         READ(scal_str,fmt) scal(nbops)
+       ELSE IF (ppos > 0) THEN
+         WRITE(tl,'(I3.3)') leng
+         WRITE(dl,'(I3.3)') leng-ppos
+         fmt='(f'//tl//'.'//dl//')'
+         READ(scal_str,fmt) scal(nbops)
+       ELSE
+         WRITE(tl,'(I3.3)') leng
+         fmt = '(I'//tl//')'
+         READ(scal_str,fmt) int_tmp
+         scal(nbops) = REAL(int_tmp,kind=ip_single_p)
+       ENDIF
+     ENDIF
+     IF (check) WRITE(*,*) 'decoop : Finished interpretation'
+     CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos)
+   ENDDO
+!-----------------------
+ END SUBROUTINE decoop_r8
+!=
+   SUBROUTINE findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
+!---------------------------------------------------------------------
+!- Subroutine finds all separators in a given string
+!- It returns the following information about str :
+!-   f_char : The first separation character
+!-            (1 for before and 2 for after)
+!-   f_pos  : The position of the first separator
+!-   s_char : The second separation character
+!-            (1 for before and 2 for after)
+!-   s_pos  : The position of the second separator
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 :: str
+   INTEGER (kind=ip_intwp_p) :: nbsep
+   CHARACTER*1 :: f_char(2),s_char(2)
+   INTEGER (kind=ip_intwp_p) :: f_pos(2),s_pos(2)
+!-
+   CHARACTER*70 :: str_tmp
+   LOGICAL :: f_found,s_found
+   INTEGER (kind=ip_intwp_p)  ::ind,xpos,leng,i
+!-
+   LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+   IF (check) &
+  &  WRITE(*,*) 'findsep : call cleanstr: ',str(1:LEN_TRIM(str))
+!-
+   CALL cleanstr(str)
+!-
+   IF (check) &
+  &  WRITE(*,*) 'findsep : out of cleanstr: ',str(1:LEN_TRIM(str))
+!-
+   xpos = INDEX(str,'X')
+   leng = LEN_TRIM(str)
+!-
+   f_pos(1:2) = (/ 0,leng+1 /)
+   f_char(1:2) = (/ '?','?' /)
+   s_pos(1:2) = (/ 0,leng+1 /)
+   s_char(1:2) = (/ '?','?' /)
+!-
+   nbsep = 0
+!-
+   f_found = .FALSE.
+   s_found = .FALSE.
+   IF (xpos > 1) THEN
+     DO i=xpos-1,1,-1
+       ind = INDEX(seps,str(i:i))
+       IF (ind > 0) THEN
+         IF (.NOT.f_found) THEN
+           f_char(1) = str(i:i)
+           f_pos(1) = i
+           nbsep = nbsep+1
+           f_found = .TRUE.
+         ELSE IF (.NOT.s_found) THEN
+           s_char(1) = str(i:i)
+           s_pos(1) = i
+           nbsep = nbsep+1
+           s_found = .TRUE.
+         ENDIF
+       ENDIF
+     ENDDO
+   ENDIF
+!-
+   f_found = .FALSE.
+   s_found = .FALSE.
+   IF (xpos < leng) THEN
+     DO i=xpos+1,leng
+       ind = INDEX(seps,str(i:i))
+       IF (ind > 0) THEN
+         IF (.NOT.f_found) THEN
+           f_char(2) = str(i:i)
+           f_pos(2) = i
+           nbsep = nbsep+1
+           f_found = .TRUE.
+         ELSE IF (.NOT.s_found) THEN
+           s_char(2) = str(i:i)
+           s_pos(2) = i
+           nbsep = nbsep+1
+           s_found = .TRUE.
+         ENDIF
+       ENDIF
+     ENDDO
+   ENDIF
+!-
+   IF (nbsep > 4) THEN
+     WRITE(str_tmp,'("number :",I3)') nbsep
+     CALL histerr(3,'findsep','How can I find that many separators',str_tmp,str)
+   ENDIF
+!-
+   IF (check) WRITE(*,*) 'Finished findsep : ',nbsep,leng
+!------------------------
+   END SUBROUTINE findsep
+!=
+   SUBROUTINE cleanstr(str)
+!---------------------------------------------------------------------
+!- We clean up the string by taking out the extra () and puting
+!- everything in lower case except for the X describing the variable
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*80 :: str
+!-
+   INTEGER (kind=ip_intwp_p) :: ind,leng,ic,it
+   LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+   leng = LEN_TRIM(str)
+   CALL strlowercase(str)
+!-
+   ind = INDEX(str,'x')
+   IF (check) WRITE (*,*) 'cleanstr 1.0 : ind = ',ind,' str = ',str(1:leng),'---'
+!-
+!- If the character before the x is not a letter then we can assume that
+!- it is the variable and promote it to a capital letter
+!-
+   DO WHILE (ind > 0)
+     ic = 0
+     IF (ind > 1) ic = IACHAR(str(ind-1:ind-1))
+     IF (ic < 97 .OR. ic > 122) THEN
+       str(ind:ind) = 'X'
+     ENDIF
+     it = INDEX(str(ind+1:leng),'x')
+     IF (it > 0) THEN
+       ind = ind+it
+     ELSE
+       ind = it
+     ENDIF
+   ENDDO
+!-
+   IF (check) WRITE (*,*) 'cleanstr 2.0 : str = ',str(1:leng),'---'
+!-
+   IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
+     str = str(2:leng-1)
+   ENDIF
+!-
+   IF (check) WRITE (*,*) 'cleanstr 3.0 : str = ',str(1:leng),'---'
+!-
+   leng = LEN_TRIM(str)
+   ind = INDEX(str,'((X))')
+   IF (ind > 0) THEN
+     str=str(1:ind-1)//'(X)'//str(ind+5:leng)//'  '
+   ENDIF
+!-
+   IF (check) WRITE (*,*) 'cleanstr 4.0 : str = ',str(1:leng),'---'
+!-
+   leng = LEN_TRIM(str)
+   ind = INDEX(str,'(X)')
+   IF (ind > 0 .AND. ind+3 < leng) THEN
+     IF ( INDEX(seps,str(ind-1:ind-1)) > 0 .AND. INDEX(seps,str(ind+3:ind+3)) > 0) THEN
+       str=str(1:ind-1)//'X'//str(ind+3:leng)//'  '
+     ENDIF
+   ENDIF
+!-
+   IF (check) WRITE (*,*) 'cleanstr 5.0 : str = ',str(1:leng),'---'
+!-
+   leng = LEN_TRIM(str)
+   ind = INDEX(str(1:leng),' ')
+   DO WHILE (ind > 0)
+     str=str(1:ind-1)//str(ind+1:leng)//' '
+     leng = LEN_TRIM(str)
+     ind = INDEX(str(1:leng),' ')
+   ENDDO
+!-
+   IF (check) WRITE (*,*) 'cleanstr 6.0 : str = ',str(1:leng),'---'
+!-------------------------
+   END SUBROUTINE cleanstr
+!=
+   SUBROUTINE mathop_r114(fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out)
+!---------------------------------------------------------------------
+!- This soubroutines gives an interface to the various operation
+!- which are allowed. The interface is general enough to allow its use
+!- for other cases.
+!-
+!- INPUT
+!-
+!- fun      : function to be applied to the vector of data
+!- nb       : Length of input vector
+!- work_in  : Input vector of data (REAL (kind=ip_single_p))
+!- miss_val : The value of the missing data flag (it has to be a
+!-            maximum value, in f90 : huge( a real ))
+!- nb_index : Length of index vector
+!- nindex   : Vector of indices
+!- scal     : A scalar value for vector/scalar operations
+!- nb_max   : maximum length of output vector
+!-
+!- OUTPUT
+!-
+!- nb_max   : Actual length of output variable
+!- work_out : Output vector after the operation was applied
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*7 :: fun
+   INTEGER (kind=ip_intwp_p):: nb,nb_max,nb_index
+   INTEGER (kind=ip_intwp_p):: nindex(nb_index)
+   REAL (kind=ip_single_p) :: miss_val
+   REAL (kind=ip_single_p) ::work_in(nb),scal
+   REAL (kind=ip_single_p) ::work_out(nb_max)
+!-
+   INTEGER (kind=ip_intwp_p):: ierr
+!-
+   INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,ALOG,SQRT,ABS
+!---------------------------------------------------------------------
+   ierr = 0
+!-
+   IF (scal >= miss_val-1.) THEN
+     IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN
+       SELECT CASE (fun)
+       CASE('sin')
+         ierr = ma_sin_r114(nb,work_in,nb_max,work_out)
+       CASE('cos')
+         ierr = ma_cos_r114(nb,work_in,nb_max,work_out)
+       CASE('tan')
+         ierr = ma_tan_r114(nb,work_in,nb_max,work_out)
+       CASE('asin')
+         ierr = ma_asin_r114(nb,work_in,nb_max,work_out)
+       CASE('acos')
+         ierr = ma_acos_r114(nb,work_in,nb_max,work_out)
+       CASE('atan')
+         ierr = ma_atan_r114(nb,work_in,nb_max,work_out)
+       CASE('exp')
+         ierr = ma_exp_r114(nb,work_in,nb_max,work_out)
+       CASE('log')
+         ierr = ma_alog_r114(nb,work_in,nb_max,work_out)
+       CASE('sqrt')
+         ierr = ma_sqrt_r114(nb,work_in,nb_max,work_out)
+       CASE('chs')
+         ierr = ma_chs_r114(nb,work_in,nb_max,work_out)
+       CASE('abs')
+         ierr = ma_abs_r114(nb,work_in,nb_max,work_out)
+       CASE('cels')
+         ierr = ma_cels_r114(nb,work_in,nb_max,work_out)
+       CASE('kelv')
+         ierr = ma_kelv_r114(nb,work_in,nb_max,work_out)
+       CASE('deg')
+         ierr = ma_deg_r114(nb,work_in,nb_max,work_out)
+       CASE('rad')
+         ierr = ma_rad_r114(nb,work_in,nb_max,work_out)
+       CASE('ident')
+         ierr = ma_ident_r114(nb,work_in,nb_max,work_out)
+       CASE DEFAULT
+         CALL histerr(3,"mathop",'scalar variable undefined and no indexing','but still unknown function',fun)
+       END SELECT
+       IF (ierr > 0) THEN
+         CALL histerr(3,"mathop",'Error while executing a simple function',fun,' ')
+       ENDIF
+     ELSE
+       SELECT CASE (fun)
+       CASE('gather')
+         ierr = ma_fugath_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('scatter')
+         IF (nb_index > nb) THEN
+           DO ierr=1,nb_max
+             work_out(ierr)=miss_val
+           ENDDO 
+           ierr=1
+         ELSE
+           ierr = ma_fuscat_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+         ENDIF
+       CASE('coll')
+         ierr = ma_fucoll_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('fill')
+         ierr = ma_fufill_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('undef')
+         ierr = ma_fuundef_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('only')
+         ierr = ma_fuonly_r114(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE DEFAULT
+         CALL histerr(3,"mathop",'scalar variable undefined and indexing',&
+        &              'was requested but with unknown function',fun)
+       END SELECT
+       IF (ierr > 0) THEN
+         CALL histerr(3,"mathop_r114",'Error while executing an indexing function',fun,' ')
+       ENDIF
+     ENDIF
+   ELSE
+     SELECT CASE (fun)
+     CASE('fumin')
+       ierr = ma_fumin_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('fumax')
+       ierr = ma_fumax_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('add')
+       ierr = ma_add_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('subi')
+       ierr = ma_subi_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('sub')
+       ierr = ma_sub_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('mult')
+       ierr = ma_mult_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('div')
+       ierr = ma_div_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('divi')
+       ierr = ma_divi_r114(nb,work_in,scal,nb_max,work_out)
+     CASE('power')
+       ierr = ma_power_r114(nb,work_in,scal,nb_max,work_out)
+     CASE DEFAULT
+       CALL histerr(3,"mathop",'Unknown operation with a scalar',fun,' ')
+     END SELECT
+     IF (ierr > 0) THEN
+       CALL histerr(3,"mathop",'Error while executing a scalar function',fun,' ')
+     ENDIF
+   ENDIF
+!---------------------------
+ END SUBROUTINE mathop_r114
+  !
+  !- INCLUDE 'mafunc_r11.inc'
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !    FUNCTIONS (only one argument)
+  !------------------------------------------------------
+  !------------------------------------------------------
+   FUNCTION ma_sin_r114(nb,x,nbo,y)
+   USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p) :: ma_sin_r114 
+    INTEGER (kind=ip_intwp_p) :: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = SIN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_sin_r114 = 0
+
+  END FUNCTION ma_sin_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_cos_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p) :: ma_cos_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = COS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_cos_r114 = 0
+
+  END FUNCTION ma_cos_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_tan_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p) :: ma_tan_r114 
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = TAN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_tan_r114 = 0
+
+  END FUNCTION ma_tan_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_asin_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p) ma_asin_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ASIN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_asin_r114 = 0
+
+  END FUNCTION ma_asin_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_acos_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_acos_r114 
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ACOS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_acos_r114 = 0
+
+  END FUNCTION ma_acos_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_atan_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER  (kind=ip_intwp_p) :: ma_atan_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ATAN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_atan_r114 = 0
+
+  END FUNCTION ma_atan_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_exp_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_exp_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = EXP(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_exp_r114 = 0
+
+  END FUNCTION ma_exp_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_alog_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_alog_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = log(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_alog_r114 = 0
+
+  END FUNCTION ma_alog_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_sqrt_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_sqrt_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = SQRT(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_sqrt_r114 = 0
+
+  END FUNCTION ma_sqrt_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_abs_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_abs_r114 
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ABS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_abs_r114 = 0
+
+  END FUNCTION ma_abs_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_chs_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+    IMPLICIT NONE
+    INTEGER (kind=ip_intwp_p):: ma_chs_r114
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)*(-1.)
+    ENDDO
+
+    nbo = nb
+    ma_chs_r114 = 0
+
+  END FUNCTION ma_chs_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_cels_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cels_r114
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)-273.15
+    ENDDO
+
+    nbo = nb
+    ma_cels_r114 = 0
+
+
+  END FUNCTION ma_cels_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_kelv_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_kelv_r114
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)+273.15
+    ENDDO
+
+    nbo = nb
+    ma_kelv_r114 = 0
+
+  END FUNCTION ma_kelv_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_deg_r114(nb,x,nbo,y)
+    USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_deg_r114
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+    DO i=1,nb
+      y(i) = x(i)*57.29577951
+    ENDDO
+
+    nbo = nb
+    ma_deg_r114 = 0
+
+  END FUNCTION ma_deg_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_rad_r114(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_rad_r114
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)*0.01745329252
+    ENDDO
+
+    nbo = nb
+    ma_rad_r114 = 0
+
+  END FUNCTION ma_rad_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_ident_r114(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_ident_r114
+    REAL (kind=ip_single_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)
+    ENDDO
+
+    nbo = nb
+    ma_ident_r114 = 0
+
+  END FUNCTION ma_ident_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !     OPERATIONS (two argument)
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_add_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_add_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)+s
+    ENDDO
+
+    nbo = nb
+    ma_add_r114 = 0
+
+  END FUNCTION ma_add_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_sub_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_sub_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)-s
+    ENDDO
+
+    nbo = nb
+    ma_sub_r114 = 0
+
+  END FUNCTION ma_sub_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_subi_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_subi_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) =  s-x(i)
+    ENDDO
+
+    nbo = nb
+    ma_subi_r114 = 0
+
+  END FUNCTION ma_subi_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_mult_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_mult_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)*s
+    ENDDO
+
+    nbo = nb
+    ma_mult_r114 = 0
+
+  END FUNCTION ma_mult_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_div_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_div_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)/s
+    ENDDO
+
+    nbo = nb
+    ma_div_r114 = 0
+
+  END FUNCTION ma_div_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_divi_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_divi_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = s/x(i)
+    ENDDO
+
+    nbo = nb
+    ma_divi_r114 = 0
+
+  END FUNCTION ma_divi_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_power_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_power_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i) ** s
+    ENDDO
+
+    nbo = nb
+    ma_power_r114 = 0
+
+  END FUNCTION ma_power_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fumin_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumin_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = min(x(i),s)
+    ENDDO
+
+    nbo = nb
+    ma_fumin_r114 = 0
+
+  END FUNCTION ma_fumin_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fumax_r114(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumax_r114
+    REAL (kind=ip_single_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = max(x(i),s)
+    ENDDO
+
+    nbo = nb
+    ma_fumax_r114 = 0
+
+  END FUNCTION ma_fumax_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuscat_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuscat_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ii,ipos
+
+    ma_fuscat_r114 = 0
+
+    DO i = 1,nbo
+      y(i) = miss_val
+    ENDDO
+
+    IF (nbi <= nb) THEN
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ind(i)) = x(ipos)
+          ELSE
+              IF (ind(i) > nbo) ma_fuscat_r114  = ma_fuscat_r114+1
+          ENDIF
+        ENDDO
+        !
+        !  Repeate the data if needed
+        !
+        IF (MINVAL(ind) < 0) THEN
+            DO i = 1,nbi
+              IF (ind(i) <= 0) THEN
+                  DO ii=1,ABS(ind(i))-1
+                    IF (ind(i+1)+ii <= nbo) THEN
+                        y(ind(i+1)+ii) = y(ind(i+1))
+                    ELSE
+                        ma_fuscat_r114  = ma_fuscat_r114+1
+                    ENDIF
+                  ENDDO
+              ENDIF
+            ENDDO
+        ENDIF
+        !
+    ELSE
+
+        ma_fuscat_r114  = 1
+
+    ENDIF
+
+  END FUNCTION ma_fuscat_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fugath_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fugath_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ipos
+
+    IF (nbi <= nbo) THEN
+
+        ma_fugath_r114 = 0
+
+        DO i=1,nbo
+          y(i) = miss_val
+        ENDDO
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ipos+1 <= nbo) THEN
+              IF (ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ipos) = x(ind(i))
+              ENDIF
+          ELSE
+              IF (ipos+1 > nbo) ma_fugath_r114  = ma_fugath_r114+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fugath_r114 = 1
+
+    ENDIF
+
+    nbo = ipos
+
+  END FUNCTION ma_fugath_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fufill_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fufill_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ii,ipos
+
+    ma_fufill_r114 = 0
+
+    IF (nbi <= nb) THEN
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ind(i)) = x(ipos)
+          ELSE
+              IF (ind(i) > nbo) ma_fufill_r114  = ma_fufill_r114+1
+          ENDIF
+        ENDDO
+        !
+        !  Repeate the data if needed
+        !
+        IF (MINVAL(ind) < 0) THEN
+            DO i = 1,nbi
+              IF (ind(i) <= 0) THEN
+                  DO ii=1,ABS(ind(i))-1
+                    IF (ind(i+1)+ii <= nbo) THEN
+                        y(ind(i+1)+ii) = y(ind(i+1))
+                    ELSE
+                        ma_fufill_r114  = ma_fufill_r114+1
+                    ENDIF
+                  ENDDO
+              ENDIF
+            ENDDO
+        ENDIF
+
+    ELSE
+
+        ma_fufill_r114  = 1
+
+    ENDIF
+
+  END FUNCTION ma_fufill_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fucoll_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fucoll_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ipos
+
+    IF (nbi <= nbo) THEN
+
+        ma_fucoll_r114 = 0
+
+        ipos = 0
+        DO i = 1,nbi
+          !
+          IF (ipos+1 <= nbo) THEN
+              IF (ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ipos) = x(ind(i))
+              ENDIF
+          ELSE
+              IF (ipos+1 > nbo) ma_fucoll_r114  = ma_fucoll_r114+1
+          ENDIF
+        ENDDO
+        !
+    ELSE
+        !
+        ma_fucoll_r114 = 1
+        !
+    ENDIF
+
+    nbo = ipos
+
+  END FUNCTION ma_fucoll_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuundef_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuundef_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    IF (nbi <= nbo .AND. nbo == nb) THEN
+
+        ma_fuundef_r114 = 0
+
+        DO i=1,nbo
+          y(i) = x(i)
+        ENDDO
+
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+              y(ind(i)) =  miss_val
+          ELSE
+              IF (ind(i) > nbo) ma_fuundef_r114  = ma_fuundef_r114+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fuundef_r114 = 1
+
+    ENDIF
+
+  END FUNCTION ma_fuundef_r114
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuonly_r114(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuonly_r114
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_single_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    IF (nbi <= nbo .AND. nbo == nb) THEN
+
+        ma_fuonly_r114 = 0
+
+        DO i=1,nbo
+          y(i) = miss_val
+        ENDDO
+
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+              y(ind(i)) =  x(ind(i))
+          ELSE
+              IF (ind(i) > nbo) ma_fuonly_r114  = ma_fuonly_r114+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fuonly_r114 = 1
+
+    ENDIF
+
+   END FUNCTION ma_fuonly_r114
+!=
+   SUBROUTINE mathop_r118(fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out)
+!---------------------------------------------------------------------
+!- This soubroutines gives an interface to the various operation
+!- which are allowed. The interface is general enough to allow its use
+!- for other cases.
+!-
+!- INPUT
+!-
+!- fun      : function to be applied to the vector of data
+!- nb       : Length of input vector
+!- work_in  : Input vector of data (REAL (kind=ip_double_p))
+!- miss_val : The value of the missing data flag (it has to be a
+!-            maximum value, in f90 : huge( a real ))
+!- nb_index : Length of index vector
+!- nindex   : Vector of indices
+!- scal     : A scalar value for vector/scalar operations
+!- nb_max   : maximum length of output vector
+!-
+!- OUTPUT
+!-
+!- nb_max   : Actual length of output variable
+!- work_out : Output vector after the operation was applied
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER*7 :: fun
+   INTEGER (kind=ip_intwp_p):: nb,nb_max,nb_index
+   INTEGER (kind=ip_intwp_p):: nindex(nb_index)
+   REAL (kind=ip_double_p) :: miss_val
+   REAL (kind=ip_double_p) ::work_in(nb),scal
+   REAL (kind=ip_double_p) ::work_out(nb_max)
+!-
+   INTEGER (kind=ip_intwp_p):: ierr
+!-
+   INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,ALOG,SQRT,ABS
+!---------------------------------------------------------------------
+   ierr = 0
+!-
+   IF (scal >= miss_val-1.) THEN
+     IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN
+       SELECT CASE (fun)
+       CASE('sin')
+         ierr = ma_sin_r118(nb,work_in,nb_max,work_out)
+       CASE('cos')
+         ierr = ma_cos_r118(nb,work_in,nb_max,work_out)
+       CASE('tan')
+         ierr = ma_tan_r118(nb,work_in,nb_max,work_out)
+       CASE('asin')
+         ierr = ma_asin_r118(nb,work_in,nb_max,work_out)
+       CASE('acos')
+         ierr = ma_acos_r118(nb,work_in,nb_max,work_out)
+       CASE('atan')
+         ierr = ma_atan_r118(nb,work_in,nb_max,work_out)
+       CASE('exp')
+         ierr = ma_exp_r118(nb,work_in,nb_max,work_out)
+       CASE('log')
+         ierr = ma_alog_r118(nb,work_in,nb_max,work_out)
+       CASE('sqrt')
+         ierr = ma_sqrt_r118(nb,work_in,nb_max,work_out)
+       CASE('chs')
+         ierr = ma_chs_r118(nb,work_in,nb_max,work_out)
+       CASE('abs')
+         ierr = ma_abs_r118(nb,work_in,nb_max,work_out)
+       CASE('cels')
+         ierr = ma_cels_r118(nb,work_in,nb_max,work_out)
+       CASE('kelv')
+         ierr = ma_kelv_r118(nb,work_in,nb_max,work_out)
+       CASE('deg')
+         ierr = ma_deg_r118(nb,work_in,nb_max,work_out)
+       CASE('rad')
+         ierr = ma_rad_r118(nb,work_in,nb_max,work_out)
+       CASE('ident')
+         ierr = ma_ident_r118(nb,work_in,nb_max,work_out)
+       CASE DEFAULT
+         CALL histerr(3,"mathop",'scalar variable undefined and no indexing','but still unknown function',fun)
+       END SELECT
+       IF (ierr > 0) THEN
+         CALL histerr(3,"mathop",'Error while executing a simple function',fun,' ')
+       ENDIF
+     ELSE
+       SELECT CASE (fun)
+       CASE('gather')
+         ierr = ma_fugath_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('scatter')
+         IF (nb_index > nb) THEN
+           DO ierr=1,nb_max
+             work_out(ierr)=miss_val
+           ENDDO 
+           ierr=1
+         ELSE
+           ierr = ma_fuscat_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+         ENDIF
+       CASE('coll')
+         ierr = ma_fucoll_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('fill')
+         ierr = ma_fufill_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('undef')
+         ierr = ma_fuundef_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE('only')
+         ierr = ma_fuonly_r118(nb,work_in,nb_index,nindex,miss_val,nb_max,work_out)
+       CASE DEFAULT
+         CALL histerr(3,"mathop",'scalar variable undefined and indexing',&
+        &              'was requested but with unknown function',fun)
+       END SELECT
+       IF (ierr > 0) THEN
+         CALL histerr(3,"mathop_r118",'Error while executing an indexing function',fun,' ')
+       ENDIF
+     ENDIF
+   ELSE
+     SELECT CASE (fun)
+     CASE('fumin')
+       ierr = ma_fumin_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('fumax')
+       ierr = ma_fumax_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('add')
+       ierr = ma_add_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('subi')
+       ierr = ma_subi_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('sub')
+       ierr = ma_sub_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('mult')
+       ierr = ma_mult_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('div')
+       ierr = ma_div_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('divi')
+       ierr = ma_divi_r118(nb,work_in,scal,nb_max,work_out)
+     CASE('power')
+       ierr = ma_power_r118(nb,work_in,scal,nb_max,work_out)
+     CASE DEFAULT
+       CALL histerr(3,"mathop",'Unknown operation with a scalar',fun,' ')
+     END SELECT
+     IF (ierr > 0) THEN
+       CALL histerr(3,"mathop",'Error while executing a scalar function',fun,' ')
+     ENDIF
+   ENDIF
+!---------------------------
+ END SUBROUTINE mathop_r118
+  !
+  !- INCLUDE 'mafunc_r11.inc'
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !    FUNCTIONS (only one argument)
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_sin_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_sin_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = SIN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_sin_r118 = 0
+
+  END FUNCTION ma_sin_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_cos_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cos_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = COS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_cos_r118 = 0
+
+  END FUNCTION ma_cos_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_tan_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_tan_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = TAN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_tan_r118 = 0
+
+  END FUNCTION ma_tan_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_asin_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_asin_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ASIN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_asin_r118 = 0
+
+  END FUNCTION ma_asin_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_acos_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_acos_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ACOS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_acos_r118 = 0
+
+  END FUNCTION ma_acos_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_atan_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_atan_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ATAN(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_atan_r118 = 0
+
+  END FUNCTION ma_atan_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_exp_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_exp_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = EXP(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_exp_r118 = 0
+
+  END FUNCTION ma_exp_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_alog_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_alog_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = log(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_alog_r118 = 0
+
+  END FUNCTION ma_alog_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_sqrt_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_sqrt_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = SQRT(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_sqrt_r118 = 0
+
+  END FUNCTION ma_sqrt_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_abs_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_abs_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = ABS(x(i))
+    ENDDO
+
+    nbo = nb
+    ma_abs_r118 = 0
+
+  END FUNCTION ma_abs_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_chs_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_chs_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)*(-1.)
+    ENDDO
+
+    nbo = nb
+    ma_chs_r118 = 0
+
+  END FUNCTION ma_chs_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_cels_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_cels_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)-273.15
+    ENDDO
+
+    nbo = nb
+    ma_cels_r118 = 0
+
+
+  END FUNCTION ma_cels_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_kelv_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_kelv_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)+273.15
+    ENDDO
+
+    nbo = nb
+    ma_kelv_r118 = 0
+
+  END FUNCTION ma_kelv_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_deg_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_deg_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+    DO i=1,nb
+      y(i) = x(i)*57.29577951
+    ENDDO
+
+    nbo = nb
+    ma_deg_r118 = 0
+
+  END FUNCTION ma_deg_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_rad_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_rad_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)*0.01745329252
+    ENDDO
+
+    nbo = nb
+    ma_rad_r118 = 0
+
+  END FUNCTION ma_rad_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_ident_r118(nb,x,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,i,ma_ident_r118
+    REAL (kind=ip_double_p) ::x(nb),y(nbo)
+
+    DO i=1,nb
+      y(i) = x(i)
+    ENDDO
+
+    nbo = nb
+    ma_ident_r118 = 0
+
+  END FUNCTION ma_ident_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !     OPERATIONS (two argument)
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_add_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_add_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)+s
+    ENDDO
+
+    nbo = nb
+    ma_add_r118 = 0
+
+  END FUNCTION ma_add_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_sub_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_sub_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)-s
+    ENDDO
+
+    nbo = nb
+    ma_sub_r118 = 0
+
+  END FUNCTION ma_sub_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_subi_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_subi_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) =  s-x(i)
+    ENDDO
+
+    nbo = nb
+    ma_subi_r118 = 0
+
+  END FUNCTION ma_subi_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_mult_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_mult_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)*s
+    ENDDO
+
+    nbo = nb
+    ma_mult_r118 = 0
+
+  END FUNCTION ma_mult_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_div_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_div_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i)/s
+    ENDDO
+
+    nbo = nb
+    ma_div_r118 = 0
+
+  END FUNCTION ma_div_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_divi_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_divi_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = s/x(i)
+    ENDDO
+
+    nbo = nb
+    ma_divi_r118 = 0
+
+  END FUNCTION ma_divi_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_power_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_power_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = x(i) ** s
+    ENDDO
+
+    nbo = nb
+    ma_power_r118 = 0
+
+  END FUNCTION ma_power_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fumin_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumin_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = min(x(i),s)
+    ENDDO
+
+    nbo = nb
+    ma_fumin_r118 = 0
+
+  END FUNCTION ma_fumin_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fumax_r118(nb,x,s,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,ma_fumax_r118
+    REAL (kind=ip_double_p) ::x(nb),s,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    DO i = 1,nb
+      y(i) = max(x(i),s)
+    ENDDO
+
+    nbo = nb
+    ma_fumax_r118 = 0
+
+  END FUNCTION ma_fumax_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuscat_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuscat_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ii,ipos
+
+    ma_fuscat_r118 = 0
+
+    DO i = 1,nbo
+      y(i) = miss_val
+    ENDDO
+
+    IF (nbi <= nb) THEN
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ind(i)) = x(ipos)
+          ELSE
+              IF (ind(i) > nbo) ma_fuscat_r118  = ma_fuscat_r118+1
+          ENDIF
+        ENDDO
+        !
+        !  Repeate the data if needed
+        !
+        IF (MINVAL(ind) < 0) THEN
+            DO i = 1,nbi
+              IF (ind(i) <= 0) THEN
+                  DO ii=1,ABS(ind(i))-1
+                    IF (ind(i+1)+ii <= nbo) THEN
+                        y(ind(i+1)+ii) = y(ind(i+1))
+                    ELSE
+                        ma_fuscat_r118  = ma_fuscat_r118+1
+                    ENDIF
+                  ENDDO
+              ENDIF
+            ENDDO
+        ENDIF
+        !
+    ELSE
+
+        ma_fuscat_r118  = 1
+
+    ENDIF
+
+  END FUNCTION ma_fuscat_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fugath_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fugath_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ipos
+
+    IF (nbi <= nbo) THEN
+
+        ma_fugath_r118 = 0
+
+        DO i=1,nbo
+          y(i) = miss_val
+        ENDDO
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ipos+1 <= nbo) THEN
+              IF (ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ipos) = x(ind(i))
+              ENDIF
+          ELSE
+              IF (ipos+1 > nbo) ma_fugath_r118  = ma_fugath_r118+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fugath_r118 = 1
+
+    ENDIF
+
+    nbo = ipos
+
+  END FUNCTION ma_fugath_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fufill_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fufill_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ii,ipos
+
+    ma_fufill_r118 = 0
+
+    IF (nbi <= nb) THEN
+
+        ipos = 0
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ind(i)) = x(ipos)
+          ELSE
+              IF (ind(i) > nbo) ma_fufill_r118  = ma_fufill_r118+1
+          ENDIF
+        ENDDO
+        !
+        !  Repeate the data if needed
+        !
+        IF (MINVAL(ind) < 0) THEN
+            DO i = 1,nbi
+              IF (ind(i) <= 0) THEN
+                  DO ii=1,ABS(ind(i))-1
+                    IF (ind(i+1)+ii <= nbo) THEN
+                        y(ind(i+1)+ii) = y(ind(i+1))
+                    ELSE
+                        ma_fufill_r118  = ma_fufill_r118+1
+                    ENDIF
+                  ENDDO
+              ENDIF
+            ENDDO
+        ENDIF
+
+    ELSE
+
+        ma_fufill_r118  = 1
+
+    ENDIF
+
+  END FUNCTION ma_fufill_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fucoll_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fucoll_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i,ipos
+
+    IF (nbi <= nbo) THEN
+
+        ma_fucoll_r118 = 0
+
+        ipos = 0
+        DO i = 1,nbi
+          !
+          IF (ipos+1 <= nbo) THEN
+              IF (ind(i) > 0) THEN
+                  ipos = ipos+1
+                  y(ipos) = x(ind(i))
+              ENDIF
+          ELSE
+              IF (ipos+1 > nbo) ma_fucoll_r118  = ma_fucoll_r118+1
+          ENDIF
+        ENDDO
+        !
+    ELSE
+        !
+        ma_fucoll_r118 = 1
+        !
+    ENDIF
+
+    nbo = ipos
+
+  END FUNCTION ma_fucoll_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuundef_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuundef_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    IF (nbi <= nbo .AND. nbo == nb) THEN
+
+        ma_fuundef_r118 = 0
+
+        DO i=1,nbo
+          y(i) = x(i)
+        ENDDO
+
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+              y(ind(i)) =  miss_val
+          ELSE
+              IF (ind(i) > nbo) ma_fuundef_r118  = ma_fuundef_r118+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fuundef_r118 = 1
+
+    ENDIF
+
+  END FUNCTION ma_fuundef_r118
+  !------------------------------------------------------
+  !------------------------------------------------------
+  !------------------------------------------------------
+  FUNCTION ma_fuonly_r118(nb,x,nbi,ind,miss_val,nbo,y)
+   USE mod_kinds_model
+
+    IMPLICIT NONE
+
+    INTEGER (kind=ip_intwp_p):: nb,nbo,nbi,ma_fuonly_r118
+    INTEGER (kind=ip_intwp_p):: ind(nbi)
+    REAL (kind=ip_double_p) ::x(nb),miss_val,y(nbo)
+
+    INTEGER (kind=ip_intwp_p):: i
+
+    IF (nbi <= nbo .AND. nbo == nb) THEN
+
+        ma_fuonly_r118 = 0
+
+        DO i=1,nbo
+          y(i) = miss_val
+        ENDDO
+
+        DO i = 1,nbi
+          IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+              y(ind(i)) =  x(ind(i))
+          ELSE
+              IF (ind(i) > nbo) ma_fuonly_r118  = ma_fuonly_r118+1
+          ENDIF
+        ENDDO
+
+    ELSE
+
+        ma_fuonly_r118 = 1
+
+    ENDIF
+
+   END FUNCTION ma_fuonly_r118
+!=
+   SUBROUTINE moycum_r4 (opp,np,px,py,pwx)
+!---------------------------------------------------------------------
+!- Does time operations
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=7) :: opp
+   INTEGER (kind=ip_intwp_p) :: np
+   REAL (kind=ip_single_p),DIMENSION(:) :: px,py
+   INTEGER (kind=ip_intwp_p) :: pwx
+!---------------------------------------------------------------------
+   IF (pwx /= 0) THEN
+     IF      (opp == 'ave') THEN
+       px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1,kind=ip_single_p)
+     ELSE IF (opp == 't_sum') THEN
+       px(1:np)=px(1:np)+py(1:np)
+     ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN
+       px(1:np)=MIN(px(1:np),py(1:np))
+     ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN
+       px(1:np)=MAX(px(1:np),py(1:np))
+     ELSE
+       CALL histerr(3,"moycum",'Unknown time operation',opp,' ')
+     ENDIF
+   ELSE
+     IF      (opp == 'l_min') THEN
+       px(1:np)=MIN(px(1:np),py(1:np))
+     ELSE IF (opp == 'l_max') THEN
+       px(1:np)=MAX(px(1:np),py(1:np))
+     ELSE
+       px(1:np)=py(1:np)
+     ENDIF
+   ENDIF
+!-----------------------
+ END SUBROUTINE moycum_r4
+!=
+   SUBROUTINE moycum_r8 (opp,np,px,py,pwx)
+!---------------------------------------------------------------------
+!- Does time operations
+!---------------------------------------------------------------------
+    USE mod_kinds_model
+    IMPLICIT NONE
+!-
+   CHARACTER(LEN=7) :: opp
+   INTEGER (kind=ip_intwp_p) :: np
+   REAL (kind=ip_double_p),DIMENSION(:) :: px,py
+   INTEGER (kind=ip_intwp_p) :: pwx
+!---------------------------------------------------------------------
+   IF (pwx /= 0) THEN
+     IF      (opp == 'ave') THEN
+       px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1,kind=ip_double_p)
+     ELSE IF (opp == 't_sum') THEN
+       px(1:np)=px(1:np)+py(1:np)
+     ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN
+       px(1:np)=MIN(px(1:np),py(1:np))
+     ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN
+       px(1:np)=MAX(px(1:np),py(1:np))
+     ELSE
+       CALL histerr(3,"moycum",'Unknown time operation',opp,' ')
+     ENDIF
+   ELSE
+     IF      (opp == 'l_min') THEN
+       px(1:np)=MIN(px(1:np),py(1:np))
+     ELSE IF (opp == 'l_max') THEN
+       px(1:np)=MAX(px(1:np),py(1:np))
+     ELSE
+       px(1:np)=py(1:np)
+     ENDIF
+   ENDIF
+!-----------------------
+ END SUBROUTINE moycum_r8
+!=
+!-----------------
+END MODULE mathelp_psmile
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_comprism_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_comprism_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_comprism_proto.F90	(revision 1677)
@@ -0,0 +1,166 @@
+MODULE mod_comprism_proto
+!     - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!
+!*    =comclim.h=  CLIM 1.1 internal include file
+!                  Coupling Library for Interfacing Models
+!
+!     - - - - - - - - - - - - - - - - - - - - - - - - - - -
+  USE mod_prism_proto
+  USE mod_kinds_model
+!
+!-----Unit number for trace file
+!
+  INTEGER(kind=ip_i4_p)	:: nulprt
+!
+!-----Models descriptors
+!
+!     ncplprocs: total number of processes involved in the coupling
+!                counting oasis process (indirect case)
+  INTEGER(kind=ip_i4_p) :: ncplprocs, mynum, mytid, ig_mynummod
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: modtid
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: kbtotproc, kbcplproc
+!! AC
+  INTEGER(kind=ip_i4_p) ::  knmods
+  CHARACTER(len=CLIM_Clength), DIMENSION(:), ALLOCATABLE :: cunames
+!!AC
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iga_unitmod
+  CHARACTER(len=6), DIMENSION(:), ALLOCATABLE :: cg_modnam
+!
+!-----Minimum exchange frequency, total time of the simulation, total 
+!     number of fields exchanged in the simulation, local communicator of 
+!     each component, maximum size of grids, initial date of the simulation
+! 
+  INTEGER(kind=ip_i4_p) :: ig_frqmin, ig_ntime, ig_clim_nfield, ig_local_comm
+  INTEGER(kind=ip_i4_p) :: ig_CLIM_Maxgrd, ig_inidate(6)
+!
+!-----Lag of exported fields, coupling period of fields, sequential index 
+!     of fields, name of exchanged fields and restart files, restart files 
+!     numbers, number of restart files, logical indicating if one field 
+!     (at least) goes through Oasis or not, field I/O status, logical 
+!     indicating a restart file netcdf or not, logical indicating if all 
+!     fields go through Oasis or not.
+!
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_lag, ig_def_lag
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_reverse, ig_def_reverse
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_invert, ig_def_invert
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_freq, ig_def_freq
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_seq, ig_def_seq
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_norstfile, ig_def_norstfile
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_aux, ig_clim_state
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_def_state
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_trans, ig_def_trans
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_clim_numlab
+!RV Will contain label numbers of fields according to their port number
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_def_numlab
+!RV
+  INTEGER(kind=ip_i4_p) :: ig_nbr_rstfile
+  CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cg_cnaminp, cg_cnamout
+  CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cg_clim_rstfile
+  CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cg_def_rstfile
+  CHARACTER(len=32), DIMENSION(:), ALLOCATABLE :: cg_clim_inpfile
+  CHARACTER(len=32), DIMENSION(:), ALLOCATABLE :: cg_def_inpfile
+  CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cg_ignout_field
+  LOGICAL :: lg_ncdfrst, lg_oasis_field
+!
+! For lons and lats and corner outputs
+  CHARACTER(len=5) :: cg_clim_cgrdnam
+  CHARACTER(len=4) :: cg_clim_lonsuf, cg_clim_latsuf
+  CHARACTER(len=4) :: crn_clim_lonsuf, crn_clim_latsuf
+  CHARACTER(len=4), DIMENSION(:), ALLOCATABLE :: &
+     cga_clim_locatorbf, cga_clim_locatoraf, cga_clim_locator
+  INTEGER(kind=ip_intwp_p)  :: ig_noc       ! Number of corners
+
+!
+!-----Local transformations descriptors
+!
+  REAL(kind=ip_single_p), DIMENSION(:,:), ALLOCATABLE :: rg_field_trans
+  REAL(kind=ip_double_p), DIMENSION(:,:), ALLOCATABLE :: dg_field_trans
+  INTEGER(kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ig_number
+  LOGICAL :: lg_dgfield
+!
+!-----Decomposition descriptors
+!
+  INTEGER(kind=ip_i4_p) :: ig_nbpart
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_length_part
+  INTEGER(kind=ip_i4_p), DIMENSION(:,:), ALLOCATABLE :: ig_def_part 
+!
+!-----Ports descriptors
+!
+  INTEGER(kind=ip_i4_p) :: nports 
+  INTEGER(kind=ip_i4_p), DIMENSION(:,:), ALLOCATABLE :: myport, irport
+  INTEGER(kind=ip_i4_p), DIMENSION(:,:), ALLOCATABLE :: mydist, irdist
+!
+!
+!-----Links descriptors
+!
+  INTEGER(kind=ip_i4_p) :: nlinks 
+  INTEGER(kind=ip_i4_p), DIMENSION(:,:), ALLOCATABLE :: mylink
+!
+!-----Data encoding
+!
+  INTEGER(kind=ip_i4_p) :: mycode
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ncode
+!
+!-----Inquiry descriptors
+!
+  INTEGER(kind=ip_i4_p) :: nbsend, nbrecv
+!
+!-----Time out stuff
+!
+  INTEGER(kind=ip_i4_p) :: ntiret, ntiogp, ntiout, nexit
+!
+!-----Timesteps descriptors
+!
+  INTEGER(kind=ip_i4_p) :: mystep, mystdt, myfcpl
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: ig_nstep
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: nstdt
+  INTEGER(kind=ip_i4_p), DIMENSION(:), ALLOCATABLE :: nfcpl 
+!
+!-----Delta time between models
+!
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: delta
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: delte
+!
+!-----Character strings
+!
+  CHARACTER*8 :: cgroup
+  CHARACTER*16 :: cnaprt
+  CHARACTER*32, DIMENSION(:), ALLOCATABLE :: cports, clrport
+  CHARACTER*32 :: cmynam
+  CHARACTER*32, DIMENSION(:), ALLOCATABLE :: cnames  
+  CHARACTER*4 :: ctype
+!
+!-----Packing area for Export and Import
+!
+  REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: pkwork 
+  REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: pkwork_field
+!
+!
+!-----CLIM/MPI2 specific variable
+!-----mpi_rank :  Rank of process in MPI communicator
+!-----mpi_size :  Size of communicator
+!-----mpi_err :  Error code of MPI calls
+!-----mpi_comm :  Communicator handle
+
+  INTEGER(kind=ip_i4_p) :: mpi_rank, mpi_size, mpi_err, mpi_comm
+!
+!-----Buffer and logical for MPI_BSend
+!
+  LOGICAL :: lg_clim_bsend 
+  REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: dg_bufsend
+!
+!
+!-----lg_mpiflag: logical true if MPI_Init has been called by application
+!
+  LOGICAL :: lg_mpiflag
+!
+!vg>>>
+!
+!-----flag to start grids writing
+!
+  INTEGER(kind=ip_i4_p) :: grids_start
+!
+!vg<<<
+    END MODULE mod_comprism_proto
+
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_kinds_model.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_kinds_model.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_kinds_model.F90	(revision 1677)
@@ -0,0 +1,39 @@
+!-------------------------------------------------------------------
+! BOP
+!
+! !MODULE: mod_kinds_model
+MODULE mod_kinds_model
+!
+! !USES:
+!
+! !PUBLIC TYPES:
+IMPLICIT NONE
+SAVE
+!
+! !PUBLIC MEMBER FUNCTIONS:
+!
+! !PUBLIC DATA MEMBERS:
+!
+! !PARAMETERS:
+  INTEGER, PARAMETER :: ip_single_p = SELECTED_REAL_KIND(6,37)
+  INTEGER, PARAMETER :: ip_double_p = SELECTED_REAL_KIND(12,307)
+#ifdef use_realtype_single
+  INTEGER, PARAMETER :: ip_realwp_p = ip_single_p
+#else
+  INTEGER, PARAMETER :: ip_realwp_p = ip_double_p  
+#endif
+  INTEGER, PARAMETER :: ip_i2_p = SELECTED_INT_KIND(4)
+  INTEGER, PARAMETER :: ip_i4_p = SELECTED_INT_KIND(9)
+#ifdef SX
+  INTEGER, PARAMETER :: ip_i8_p = SELECTED_INT_KIND(15)
+#else
+  INTEGER, PARAMETER :: ip_i8_p = SELECTED_INT_KIND(18)
+#endif
+  INTEGER, PARAMETER :: ip_intwp_p = ip_i4_p 
+!
+! !DESCRIPTION:
+! This modules contains the parameters defining the precision used for 
+! real and integer variables
+!   
+  END MODULE mod_kinds_model
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_def_partition_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_def_partition_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_def_partition_proto.F90	(revision 1677)
@@ -0,0 +1,128 @@
+MODULE mod_prism_def_partition_proto
+!
+!
+!**** DEFINE
+!
+!     Purpose:
+!      Routine prism_def_partition is in a module.
+!     
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses assumed shape array method to dimension local arrays.        
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/06     created
+!
+!*-----------------------------------------------------------------------
+
+CONTAINS
+!
+  SUBROUTINE prism_def_partition_proto (id_part, kparal, kinfo)
+!
+!*    *** Def_partition ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        define a decomposition
+!
+!     interface:
+!     ----------
+!        id_part : field decomposition id
+!        kparal : type of parallel decomposition
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Arnaud Caubel - FECIT
+!
+!  ----------------------------------------------------------------
+   USE mod_kinds_model
+   USE mod_prism_proto
+   USE mod_comprism_proto
+!  ----------------------------------------------------------------
+   INTEGER (kind=ip_intwp_p)       kinfo, id_part
+   INTEGER (kind=ip_intwp_p), DIMENSION(:) :: kparal
+!  ----------------------------------------------------------------
+
+   ig_nbpart = ig_nbpart + 1
+   id_part = ig_nbpart
+   IF (kparal(CLIM_Strategy).EQ.CLIM_Serial) THEN
+!
+      ig_def_part(CLIM_Strategy,ig_nbpart)   = CLIM_Serial
+      ig_def_part(CLIM_Segments,ig_nbpart)   = 1
+      ig_def_part(CLIM_Segments+1,ig_nbpart) = 0
+      ig_def_part(CLIM_Segments+2,ig_nbpart) = kparal(CLIM_Length)
+      ig_length_part(ig_nbpart) = kparal(CLIM_Length)
+!
+   ELSEIF (kparal(CLIM_Strategy).EQ.CLIM_Apple) THEN
+!
+      ig_def_part(CLIM_Strategy,ig_nbpart)   = CLIM_Apple
+      ig_def_part(CLIM_Segments,ig_nbpart)   = 1
+      ig_def_part(CLIM_Segments+1,ig_nbpart) = kparal(CLIM_Offset)
+      ig_def_part(CLIM_Segments+2,ig_nbpart) = kparal(CLIM_Length)
+      ig_length_part(ig_nbpart) = kparal(CLIM_Length)
+!
+   ELSEIF (kparal(CLIM_strategy).EQ.CLIM_Box) THEN
+!
+       IF (kparal(CLIM_SizeY) .GT. CLIM_MaxSegments) THEN
+           WRITE (nulprt, *) &
+              'Parameter CLIM_MaxSegments must be greater or equal to the field local extent in Y.'
+           WRITE (nulprt, *) &
+              'Adjust CLIM_MaxSegments in mod_prism_proto.F90 and recompile your model.'
+           WRITE (nulprt, *) &
+              'Abort in mod_prism_def_partition_proto.F90'
+           CALL flush(nulprt)
+           CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+       ENDIF
+      ig_def_part(CLIM_Strategy,ig_nbpart)   = CLIM_Box
+      ig_def_part(CLIM_Segments,ig_nbpart)   = kparal(CLIM_SizeY)
+      DO is=1,kparal(CLIM_SizeY)
+         ig_def_part(CLIM_Segments+2*is-1,ig_nbpart) = &
+              kparal(CLIM_Offset) + (is-1) * kparal(CLIM_LdX)
+         ig_def_part(CLIM_Segments+2*is,ig_nbpart) = kparal(CLIM_SizeX)
+      ENDDO
+      ig_length_part(ig_nbpart) = kparal(CLIM_SizeX) * kparal(CLIM_SizeY)
+!
+   ELSEIF (kparal(CLIM_strategy).EQ.CLIM_Orange) THEN
+!
+       IF (kparal(CLIM_Segments) .GT. CLIM_MaxSegments) THEN
+           WRITE (nulprt, *) &
+              'Parameter CLIM_MaxSegments must be greater or equal to the number of segments.'
+           WRITE (nulprt, *) &
+              'Adjust CLIM_MaxSegments in mod_prism_proto.F90 and recompile your model.'
+           WRITE (nulprt, *) &
+              'Abort in mod_prism_def_partition_proto.F90'
+           CALL flush(nulprt)
+           CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+       ENDIF
+      ig_def_part(CLIM_Strategy,ig_nbpart)   = CLIM_Orange
+      ig_def_part(CLIM_Segments,ig_nbpart)   = kparal(CLIM_Segments)
+      myport(4,ig_nbpart) = 0
+      DO is=1,2*kparal(CLIM_Segments)
+         ig_def_part(CLIM_Segments+is,ig_nbpart) = kparal(CLIM_Segments+is)
+         IF (MOD(is,2).EQ.0) THEN
+            ig_length_part(ig_nbpart) = ig_length_part(ig_nbpart) + &
+                 kparal(CLIM_Segments+is)
+         ENDIF
+      ENDDO
+   ENDIF
+ END SUBROUTINE prism_def_partition_proto
+
+END MODULE mod_prism_def_partition_proto
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_comm.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_comm.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_comm.F90	(revision 1677)
@@ -0,0 +1,167 @@
+MODULE mod_prism_get_comm
+
+  IMPLICIT NONE
+
+  INTERFACE prism_get_intercomm
+    
+    MODULE PROCEDURE prism_get_intercomm_1mod
+       
+  END INTERFACE
+
+  INTERFACE prism_get_intracomm
+
+    MODULE PROCEDURE prism_get_intracomm_1mod
+       
+  END INTERFACE
+!
+!-----Type model to store information about models
+!
+  TYPE :: model
+    character(len=6) :: name
+    integer          :: master_proc   !! rank of master proc in global communicator
+  END TYPE model
+
+  TYPE(model), ALLOCATABLE, DIMENSION(:), PRIVATE :: coupling_models
+
+CONTAINS
+
+  SUBROUTINE prism_get_intercomm_1mod(il_local_comm, cd_name, kinfo)
+!
+!*    *** Get_intercomm ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        Get an intercommunicator.
+!
+!     interface:
+!     ----------
+!        il_local_comm : intercommunicator
+!        cd_name : name of the model to be linked with thanks to the intercommunicator
+!        kinfo  : exit status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Arnaud Caubel
+!
+!     ----------------------------------------------------------------
+!
+    USE mod_kinds_model
+    USE mod_comprism_proto
+
+    include 'mpif.h'
+
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)	:: il, il_local_comm, kinfo, il_local_intercomm
+    INTEGER (kind=ip_intwp_p)	:: tag
+    CHARACTER (len=6) :: cd_name
+    LOGICAL :: ll_found
+!     ----------------------------------------------------------------
+
+    ll_found= .false.
+
+    ALLOCATE(coupling_models(knmods))
+    coupling_models(1)%master_proc=1
+    coupling_models(1)%name=trim(cunames(2))
+    DO il=2,knmods
+      coupling_models(il)%master_proc= &
+         coupling_models(il-1)%master_proc+ kbtotproc(il-1)
+      coupling_models(il)%name= &
+         TRIM(cunames(coupling_models(il)%master_proc+1))
+    ENDDO
+      
+    DO il=1,knmods
+      IF (cd_name .EQ. coupling_models(il)%name .AND. .NOT. ll_found) THEN
+          tag=ICHAR(TRIM(cmynam))+ICHAR(TRIM(cd_name))
+      CALL mpi_intercomm_create(ig_local_comm, 0, MPI_COMM_WORLD, coupling_models(il)%master_proc, &
+             tag, il_local_intercomm, kinfo)
+          ll_found= .true.
+      ENDIF
+    ENDDO
+    
+    il_local_comm = il_local_intercomm
+
+    IF (ll_found) THEN
+        kinfo = CLIM_Ok
+    ELSE
+        kinfo = CLIM_BadName
+    ENDIF
+
+    deallocate (coupling_models)
+
+  END SUBROUTINE prism_get_intercomm_1mod
+
+  SUBROUTINE prism_get_intracomm_1mod(il_local_comm, cd_name, kinfo)
+!
+!*    *** Get_intracomm ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        Get an intracommunicator.
+!
+!     interface:
+!     ----------
+!        il_local_comm : intracommunicator
+!        cd_name : name of the model to share the communicator with
+!        kinfo  : exit status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Arnaud Caubel
+!
+!     ----------------------------------------------------------------
+!
+    USE mod_kinds_model
+    USE mod_comprism_proto
+
+    include 'mpif.h'
+
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)	:: il, il_local_comm, kinfo, il_local_intercomm
+    INTEGER (kind=ip_intwp_p)	:: il_new_local_comm, tag
+    CHARACTER (len=6) :: cd_name
+    LOGICAL :: ll_found
+!     ----------------------------------------------------------------
+
+    ll_found= .false.
+
+    ALLOCATE(coupling_models(knmods))
+    coupling_models(1)%master_proc=1
+    coupling_models(1)%name=trim(cunames(2))
+    DO il=2,knmods
+      coupling_models(il)%master_proc= &
+         coupling_models(il-1)%master_proc+ kbtotproc(il-1)
+      coupling_models(il)%name= &
+         TRIM(cunames(coupling_models(il)%master_proc+1))
+    ENDDO
+      
+    DO il=1,knmods
+      IF (cd_name .EQ. coupling_models(il)%name .AND. .NOT. ll_found) THEN
+          tag=ICHAR(TRIM(cmynam))+ICHAR(TRIM(cd_name))
+      CALL mpi_intercomm_create(ig_local_comm, 0, MPI_COMM_WORLD, coupling_models(il)%master_proc, &
+             tag, il_local_intercomm, kinfo)
+          CALL mpi_intercomm_merge(il_local_intercomm,.FALSE., il_new_local_comm, kinfo)
+          ll_found= .true.
+      ENDIF
+    ENDDO
+    
+    il_local_comm = il_new_local_comm
+
+    IF (ll_found) THEN
+        kinfo = CLIM_Ok
+    ELSE
+        kinfo = CLIM_BadName
+    ENDIF
+
+    deallocate (coupling_models)
+
+  END SUBROUTINE prism_get_intracomm_1mod
+
+END MODULE mod_prism_get_comm
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_proto.F90	(revision 1677)
@@ -0,0 +1,1812 @@
+module mod_prism_get_proto
+#include <psmile_os.h>
+
+  interface prism_get_proto
+     
+#ifndef __NO_4BYTE_REALS
+     module procedure prism_get_proto_r14
+     module procedure prism_get_proto_r24
+#endif
+     module procedure prism_get_proto_r18, &
+                      prism_get_proto_r28
+     
+  end interface
+
+contains
+
+  SUBROUTINE prism_get_proto_r14(id_port_id,kstep,rd_field,kinfo)
+!
+!*    *** PRISM_get ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        recv pfield from oasis or models connected to port id_port_id
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 pfield	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1 or mpi-2
+!
+!     author:
+!     -------
+!        Arnaud Caubel  - Fecit (08/02 - created from CLIM_Import)
+!
+!     modified:
+!     ---------
+!        Reiner Vogelsang, SGI,  27 April 2003
+!        - Screening of 4 byte real interfaces in case a of dbl4 compilation.
+!        File has to be preprocessed with -D__SXdbl4.
+!        S. Legutke,       MPI M&D  (05/03 - kinfo = PRISM_Recvd added)
+!
+!---------------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT none
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id,kstep
+    INTEGER(kind=ip_intwp_p), intent(out) :: kinfo
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field
+!     ----------------------------------------------------------------
+    INTEGER(kind=ip_intwp_p)     info, ip, iport 
+    INTEGER(kind=ip_intwp_p)	  irecv, imod, ilk, iseg, is, ilgb
+    INTEGER(kind=ip_intwp_p)     itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER(kind=ip_intwp_p)     iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
+!jl
+#ifdef __DEBUG
+    INTEGER(kind=ip_intwp_p)     icount
+    INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
+    LOGICAL ::                   iflag
+#endif
+!     ----------------------------------------------------------------
+!
+    istatus(:)=0
+
+!*    0. First Check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Get - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    irecv = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime .or. &
+         ig_def_state(id_port_id) .eq. ip_auxilary) THEN 
+       GOTO 1010
+    ENDIF
+    IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!*    Test if the current time is a coupling (or I/O) time
+! 
+    IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
+!
+!*    If the user indicated in the namcouple that the field is
+!*    a field input-from-file (keyword 'INPUT' at the end of the
+!*    field 1st line), do the reading from file here, e.g.:
+!
+#if !defined key_noIO
+       IF (ig_def_state(iport) .EQ. ip_input) THEN
+           CALL psmile_read_4(iport,rd_field,kstep)
+           kinfo = PRISM_Input
+       ENDIF
+#endif
+!
+!* Define return code (direct or via Oasis does not matter)
+!
+       IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
+           kinfo = PRISM_FromRest
+#if !defined key_noIO
+           IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
+              ig_def_state(iport) .EQ. ip_expout) THEN
+               kinfo = PRISM_FromRestOut
+           ENDIF
+#endif  
+       ELSE
+           IF (ig_def_state(iport) .NE. ip_input) THEN
+               kinfo = PRISM_Recvd
+!
+#if !defined key_noIO
+               IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+                  ig_def_state(iport) .EQ. ip_ignout) THEN
+                   kinfo = PRISM_RecvOut
+               ENDIF
+#endif
+           ENDIF
+       ENDIF
+!
+       IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
+            (ig_def_state(iport) .eq. ip_ignored .or. &
+            ig_def_state(iport) .eq. ip_ignout)) THEN
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!*       Test if model is serial or parallel and if variables are real
+!        or double precision
+          IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+             call read_filer4(rd_field, cports(iport),iport)
+          ELSE
+             call read_file_parar4(rd_field, cports(iport),iport)
+          ENDIF
+#if !defined key_noIO
+          IF (ig_def_state(iport) .EQ. ip_ignout) &
+             CALL psmile_write_4(iport,rd_field,kstep)
+#endif           
+       ELSE
+!*
+!*    If the user indicated in the namcouple that the field is
+!*    a coupling field then do the import :
+          IF (ig_def_state(iport) .ne. ip_output .and. &
+               ig_def_state(iport) .ne. ip_input) THEN
+!
+!*       Check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!     
+             DO ip=1,myport(5,iport)
+!     
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - kstep / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+!*   Implementation with "blocking" receives : the program will wait
+!*   indefinitely until a message is received (this may generate a
+!*   deadlock if all models are waiting on a receive).
+!*   However this method will be more efficient in most cases than the
+!*   receives with a time-out loop. 
+!     
+#ifdef __DEBUG
+!jl
+!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
+!jl exist in the network  (2004-04-28)
+!jl Also, allows to check the timing of the receives of messages 
+!jl For completion, the same syntax should be added in oasis "Getfld"
+!jl
+                CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                ' comm = ',mpi_comm,' result is : ',iflag
+                call flush(nulprt)
+
+                IF (.NOT.iflag) THEN
+                   icount = 0
+   WAITLOOP:       DO
+                   CALL  MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                   icount = icount + 1
+                   IF ( iflag ) EXIT WAITLOOP
+                   IF ( icount .GE. icountmax ) THEN
+                      WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                      ' still negative after ',icountmax,' seconds : Abort the job'
+                      call flush(nulprt)
+                      CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+                   ENDIF
+                   call sleep(1)
+                   END DO WAITLOOP
+                   WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
+                   call flush(nulprt)
+                ENDIF
+!jl
+#endif
+                CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
+                     itid, itag, mpi_comm, istatus, info )
+                CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
+                     info )
+!     
+                IF ( info .EQ. CLIM_ok  .AND.  imaxbyt .GT. 0) THEN
+                   ilgb = 0
+                   iposbuf = 0
+                   DO is=1,iseg
+                      ioff = mylink(4+2*is-1,ilk) * 2 + 1
+                      il_len = mylink(4+2*is,ilk)
+!     
+                      IF ( ityp .EQ. PRISM_Real ) THEN
+                         CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
+                              iposbuf, rd_field(ioff), il_len, &
+                              MPI_REAL, mpi_comm, info)
+                      ELSE
+                         WRITE(nulprt,*)'Get - pb type incorrect ',ityp
+                         kinfo = CLIM_BadType
+                         GO TO 1010
+                      ENDIF
+                      ilgb = ilgb + il_len
+                   ENDDO
+                   IF (ilgb*ibyt .le. imaxbyt) THEN
+                      irecv  = irecv + 1
+                      nbrecv = nbrecv + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
+                           'Get - <from:',imod, &
+                           '> <step:',kstep, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag,'>' 
+                   ELSE
+                      kinfo = CLIM_Unpack
+                      WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
+                           info,'>'
+                   ENDIF
+                ELSE
+                   kinfo = CLIM_TimeOut
+                   WRITE(nulprt,FMT='(A,I3,A)') &
+                        'Get - abnormal exit from trecv <mpi ',info,'>'
+                ENDIF
+! 
+             ENDDO
+!     
+             WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
+!
+#if !defined key_noIO
+             IF (ig_def_state(iport) .eq. ip_expout .or. &
+                  ig_def_state(iport) .eq. ip_ignout) &
+!
+!*    If the user indicated in the namcouple that the field must be written 
+!*     to file, do the writing here :
+!
+                  CALL psmile_write_4(iport,rd_field,kstep)
+#endif
+          ENDIF
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_get_proto_r14
+
+  SUBROUTINE prism_get_proto_r18(id_port_id,kstep,rd_field,kinfo)
+!
+!*    *** PRISM_get ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        recv pfield from oasis or models connected to port id_port_id
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1 or mpi-2
+!
+!     author:
+!     -------
+!        Arnaud Caubel  - Fecit (08/02 - created from CLIM_Import)
+!        S. Legutke,    - MPI M&D  (05/03 - kinfo = PRISM_Recvd added)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT none
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id,kstep
+    INTEGER (kind=ip_intwp_p), intent(out) :: kinfo
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)     info, ip, iport 
+    INTEGER (kind=ip_intwp_p)	    irecv, imod, ilk, iseg, is, ilgb
+    INTEGER (kind=ip_intwp_p)     itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)     iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
+!jl
+#ifdef __DEBUG
+    INTEGER(kind=ip_intwp_p)     icount
+    INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
+    LOGICAL ::                   iflag
+#endif
+!     ----------------------------------------------------------------
+!
+    istatus(:)=0
+!
+!*    0. First Check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Get - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    irecv = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime .or. &
+         ig_def_state(id_port_id) .eq. ip_auxilary) THEN 
+       GOTO 1010
+    ENDIF
+    IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!*    Test if the current time is a coupling (or I/O) time
+! 
+    IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
+!
+!*    If the user indicated in the namcouple that the field is
+!*    a field input-from-file (keyword 'INPUT' at the end of the
+!*    field 1st line), do the reading from file here, e.g.:
+!
+#if !defined key_noIO
+       IF (ig_def_state(iport) .eq. ip_input) then
+           WRITE(nulprt,*) 'Get - Input field'
+           CALL psmile_read_8(iport,rd_field,kstep)
+           kinfo = PRISM_Input
+       ENDIF
+#endif
+!
+!* Define return code (direct or via Oasis does not matter)
+!
+       IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
+           kinfo = PRISM_FromRest
+#if !defined key_noIO
+           IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
+              ig_def_state(iport) .EQ. ip_expout) THEN
+               kinfo = PRISM_FromRestOut
+           ENDIF
+#endif  
+       ELSE
+           IF (ig_def_state(iport) .NE. ip_input) THEN
+               kinfo = PRISM_Recvd
+!
+#if !defined key_noIO
+               IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+                  ig_def_state(iport) .EQ. ip_ignout) THEN
+                   kinfo = PRISM_RecvOut
+               ENDIF
+#endif
+           ENDIF
+       ENDIF
+!
+!*     Test if first import and if the user indicated in the 
+!*     namcouple that the field is exchanged directly 
+!*     between the models and not treated by Oasis
+!*     (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
+!*     do the reading from restart file (not implemented).
+! 
+       IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
+            (ig_def_state(iport) .eq. ip_ignored .or. &
+          ig_def_state(iport) .eq. ip_ignout)) THEN
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!*       Test if model is serial or parallel and if variables are real
+!        or double precision
+          IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+             call read_filer8(rd_field, cports(iport),iport)
+          ELSE
+             call read_file_parar8(rd_field, cports(iport),iport)
+          ENDIF
+#if !defined key_noIO
+          IF (ig_def_state(iport) .EQ. ip_ignout) &
+              CALL psmile_write_8(iport,rd_field,kstep)
+#endif
+       ELSE
+!*
+!*    If the user indicated in the namcouple that the field is
+!*    a coupling field then do the import :
+!
+          IF (ig_def_state(iport) .ne. ip_output .and. &
+               ig_def_state(iport) .ne. ip_input) THEN
+!
+!*       Check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!  
+             DO ip=1,myport(5,iport)
+!     
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - kstep / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+!*   Implementation with "blocking" receives : the program will wait
+!*   indefinitely until a message is received (this may generate a
+!*   deadlock if all models are waiting on a receive).
+!*   However this method will be more efficient in most cases than the
+!*   receives with a time-out loop. 
+!     
+!
+#ifdef __DEBUG
+!jl
+!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
+!jl exist in the network  (2004-04-28)
+!jl
+                CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                ' comm = ',mpi_comm,' result is : ',iflag
+                call flush(nulprt)
+
+                IF (.NOT.iflag) THEN
+                   icount = 0
+   WAITLOOP:       DO
+                   CALL  MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                   icount = icount + 1
+                   IF ( iflag ) EXIT WAITLOOP
+                   IF ( icount .GE. icountmax ) THEN
+                      WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                      ' still negative after ',icountmax,' seconds : Abort the job'
+                      call flush(nulprt)
+                      CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+                   ENDIF
+                   call sleep(1)
+                   END DO WAITLOOP
+                   WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
+                   call flush(nulprt)
+                ENDIF
+!jl
+#endif
+                CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
+                     itid, itag, mpi_comm, istatus, info )
+                CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
+                     info )
+!     
+                IF ( info .EQ. CLIM_ok  .AND.  imaxbyt .GT. 0) THEN
+                   ilgb = 0
+                   iposbuf = 0
+                   DO is=1,iseg
+                      ioff = mylink(4+2*is-1,ilk) + 1
+                      il_len = mylink(4+2*is,ilk)
+!     
+!                      IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
+                      IF ( ityp .EQ. PRISM_Real ) THEN
+                         CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
+                              iposbuf, rd_field(ioff), il_len, &
+                              MPI_DOUBLE_PRECISION, mpi_comm, info)
+                      ELSE
+                         WRITE(nulprt,*)'Get - pb type incorrect ',ityp
+                         kinfo = CLIM_BadType
+                         GO TO 1010
+                      ENDIF
+                      ilgb = ilgb + il_len
+                   ENDDO
+                   IF (ilgb*ibyt .le. imaxbyt) THEN
+                      irecv  = irecv + 1
+                      nbrecv = nbrecv + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
+                           'Get - <from:',imod, &
+                           '> <step:',kstep, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag,'>' 
+                   ELSE
+                      kinfo = CLIM_Unpack
+                      WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
+                           info,'>'
+                   ENDIF
+                ELSE
+                   kinfo = CLIM_TimeOut
+                   WRITE(nulprt,FMT='(A,I3,A)') &
+                        'Get - abnormal exit from trecv <mpi ',info,'>'
+                ENDIF
+! 
+             ENDDO
+!     
+             WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
+!
+#if !defined key_noIO
+             IF (ig_def_state(iport) .eq. ip_expout .or. &
+                  ig_def_state(iport) .eq. ip_ignout) &
+!
+!*    If the user indicated in the namcouple that the field must be written 
+!*     to file, do the writing here :
+!
+                  CALL psmile_write_8(iport,rd_field,kstep) 
+#endif
+          ENDIF
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_get_proto_r18
+
+  SUBROUTINE prism_get_proto_r24(id_port_id,kstep,rd_field_2d,kinfo)
+!
+!*    *** PRISM_get ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        recv pfield from oasis or models connected to port id_port_id
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field_2d : buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1 or mpi-2
+!
+!     author:
+!     -------
+!        Arnaud Caubel  - Fecit (08/02 - created from CLIM_Import)
+!        S. Legutke,    - MPI M&D  (05/03 - kinfo = PRISM_Recvd added)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT none
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id, kstep
+    INTEGER (kind=ip_intwp_p), intent(out) :: kinfo
+    REAL(kind=ip_single_p), DIMENSION(:,:), intent(inout) :: rd_field_2d
+!     ----------------------------------------------------------------    
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+    INTEGER (kind=ip_intwp_p)     info, ip, iport 
+    INTEGER (kind=ip_intwp_p)	  irecv, imod, ilk, iseg, is, ilgb
+    INTEGER (kind=ip_intwp_p)     itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)     iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
+!jl
+#ifdef __DEBUG
+    INTEGER(kind=ip_intwp_p)     icount
+    INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
+    LOGICAL ::                   iflag
+#endif
+!     ----------------------------------------------------------------
+!
+    rd_field(:)=0
+!
+!*    0. First Check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Get - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    irecv = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime .or. &
+         ig_def_state(id_port_id) .eq. ip_auxilary) THEN 
+       GOTO 1010
+    ENDIF
+    IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!
+!*    Test if the current time is a coupling (or I/O) time
+! 
+    IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
+!
+!*    If the user indicated in the namcouple that the field is
+!*    a field input-from-file (keyword 'INPUT' at the end of the
+!*    field 1st line), do the reading from file here, e.g.:
+!
+#if !defined key_noIO
+        IF (ig_def_state(iport) .EQ. ip_input) THEN
+            CALL psmile_read_4(iport,rd_field,kstep)
+            kinfo = PRISM_Input
+        ENDIF
+#endif
+!
+!* Define return code (direct or via Oasis does not matter)
+!
+       IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
+           kinfo = PRISM_FromRest
+#if !defined key_noIO
+           IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
+              ig_def_state(iport) .EQ. ip_expout) THEN
+               kinfo = PRISM_FromRestOut
+           ENDIF
+#endif  
+       ELSE
+           IF (ig_def_state(iport) .NE. ip_input) THEN
+               kinfo = PRISM_Recvd
+!
+#if !defined key_noIO
+               IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+                  ig_def_state(iport) .EQ. ip_ignout) THEN
+                   kinfo = PRISM_RecvOut
+               ENDIF
+#endif
+           ENDIF
+       ENDIF
+!
+!*     Test if first import and if the user indicated in the 
+!*     namcouple that the field is
+!*     exchanged directly between the models and not treated by
+!*     Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
+!*     do the reading from restart file (not implemented).
+! 
+       IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
+            (ig_def_state(iport) .eq. ip_ignored .or. &
+            ig_def_state(iport) .eq. ip_ignout)) THEN
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!*       Test if model is serial or parallel and if variables are real
+!        or double precision
+          IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+             call read_filer4(rd_field, cports(iport),iport)
+          ELSE
+             call read_file_parar4(rd_field, cports(iport),iport)
+          ENDIF
+#if !defined key_noIO
+          IF (ig_def_state(iport) .EQ. ip_ignout) &
+               call psmile_write_4(iport,rd_field,kstep)
+#endif
+       ELSE
+!
+!*    If the user indicated in the namcouple that the field is
+!*    a coupling field then do the import :
+          IF (ig_def_state(iport) .NE. ip_output .AND. &
+               ig_def_state(iport) .ne. ip_input) THEN
+!
+!*       Check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!     
+             DO ip=1,myport(5,iport)
+!     
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - kstep / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+!*   Implementation with "blocking" receives : the program will wait
+!*   indefinitely until a message is received (this may generate a
+!*   deadlock if all models are waiting on a receive).
+!*   However this method will be more efficient in most cases than the
+!*   receives with a time-out loop. 
+!     
+#ifdef __DEBUG
+!
+!jl
+!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
+!jl exist in the network  (2004-04-28)
+!jl
+                CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                ' comm = ',mpi_comm,' result is : ',iflag
+                call flush(nulprt)
+
+                IF (.NOT.iflag) THEN
+                   icount = 0
+   WAITLOOP:       DO
+                   CALL  MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                   icount = icount + 1
+                   IF ( iflag ) EXIT WAITLOOP
+                   IF ( icount .GE. icountmax ) THEN
+                      WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                      ' still negative after ',icountmax,' seconds : Abort the job'
+                      call flush(nulprt)
+                      CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+                   ENDIF
+                   call sleep(1)
+                   END DO WAITLOOP
+                   WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
+                   call flush(nulprt)
+                ENDIF
+!jl
+#endif
+                CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
+                     itid, itag, mpi_comm, istatus, info )
+                CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
+                     info )
+!     
+                IF ( info .EQ. CLIM_ok  .AND.  imaxbyt .GT. 0) THEN
+                   ilgb = 0
+                   iposbuf = 0
+                   DO is=1,iseg
+                      ioff = mylink(4+2*is-1,ilk) * 2 + 1
+                      il_len = mylink(4+2*is,ilk)
+!     
+                      IF ( ityp .EQ. PRISM_Real ) THEN
+                         CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
+                              iposbuf, rd_field(ioff), il_len, &
+                              MPI_REAL, mpi_comm, info)
+                      ELSE
+                         WRITE(nulprt,*)'Get - pb type incorrect ',ityp
+                         kinfo = CLIM_BadType
+                         GO TO 1010
+                      ENDIF
+                      ilgb = ilgb + il_len
+                   ENDDO
+                   IF (ilgb*ibyt .le. imaxbyt) THEN
+                      irecv  = irecv + 1
+                      nbrecv = nbrecv + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
+                           'Get - <from:',imod, &
+                           '> <step:',kstep, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag,'>' 
+                   ELSE
+                      kinfo = CLIM_Unpack
+                      WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
+                           info,'>'
+                   ENDIF
+                ELSE
+                   kinfo = CLIM_TimeOut
+                   WRITE(nulprt,FMT='(A,I3,A)') &
+                        'Get - abnormal exit from trecv <mpi ',info,'>'
+                ENDIF
+! 
+             ENDDO
+!     
+             WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
+!
+#if !defined key_noIO
+             IF (ig_def_state(iport) .eq. ip_expout .or. &
+                  ig_def_state(iport) .eq. ip_ignout) &
+!
+!*    If the user indicated in the namcouple that the field must be written 
+!*     to file, do the writing here :
+!
+                call psmile_write_4(iport,rd_field,kstep)
+#endif
+         ENDIF
+          rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), &
+               size(rd_field_2d,2)/)) 
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_get_proto_r24
+
+  SUBROUTINE prism_get_proto_r28(id_port_id,kstep,rd_field_2d,kinfo)
+!
+!*    *** PRISM_get ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        recv pfield from oasis or models connected to port id_port_id
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field_2d : buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1 or mpi-2
+!
+!     author:
+!     -------
+!        Arnaud Caubel  - Fecit    (08/02 - created from CLIM_Import)
+!        S. Legutke     - MPI M&D  (05/03 - kinfo = PRISM_Recvd added)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT none
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id, kstep
+    INTEGER(kind=ip_intwp_p), intent(out) :: kinfo
+    REAL(kind=ip_double_p), DIMENSION(:,:), intent(inout) :: rd_field_2d
+!     ----------------------------------------------------------------    
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+    INTEGER(kind=ip_intwp_p)     info, ip, iport 
+    INTEGER(kind=ip_intwp_p)	  irecv, imod, ilk, iseg, is, ilgb
+    INTEGER(kind=ip_intwp_p)     itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER(kind=ip_intwp_p)     iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
+!jl
+#ifdef __DEBUG
+    INTEGER(kind=ip_intwp_p)     icount
+    INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
+    LOGICAL ::                   iflag
+#endif
+!     ----------------------------------------------------------------
+    rd_field(:)=0    
+!
+!*    0. First Check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Get - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    irecv = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+   IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime .or. &
+         ig_def_state(id_port_id) .eq. ip_auxilary) THEN 
+       GOTO 1010
+    ENDIF 
+    IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!*    Test if the current time is a coupling (or I/O) time
+! 
+    IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
+!
+!*    If the user indicated in the namcouple that the field is
+!*    a field input-from-file (keyword 'INPUT' at the end of the
+!*    field 1st line), do the reading from file here, e.g.:
+!
+#if !defined key_noIO
+        IF (ig_def_state(iport) .EQ. ip_input) THEN
+           CALL psmile_read_8(iport,rd_field,kstep)
+           kinfo = PRISM_Input
+       ENDIF
+#endif
+!
+!* Define return code (direct or via Oasis does not matter)
+!
+       IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
+           kinfo = PRISM_FromRest
+#if !defined key_noIO
+           IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
+              ig_def_state(iport) .EQ. ip_expout) THEN
+               kinfo = PRISM_FromRestOut
+           ENDIF
+#endif  
+       ELSE
+           IF (ig_def_state(iport) .NE. ip_input) THEN
+               kinfo = PRISM_Recvd
+!
+#if !defined key_noIO
+               IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+                  ig_def_state(iport) .EQ. ip_ignout) THEN
+                   kinfo = PRISM_RecvOut
+               ENDIF
+#endif
+           ENDIF
+       ENDIF
+!
+!*     Test if first import and if the user indicated in the 
+!*     namcouple that the field is
+!*     exchanged directly between the models and not treated by
+!*     Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
+!*     do the reading from restart file (not implemented).
+! 
+       IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
+            (ig_def_state(iport) .eq. ip_ignored .or. &
+            ig_def_state(iport) .eq. ip_ignout)) THEN
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!*       Test if model is serial or parallel and if variables are real
+!        or double precision
+          IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+             call read_filer8(rd_field, cports(iport),iport)
+          ELSE
+             call read_file_parar8(rd_field, cports(iport),iport)
+          ENDIF
+#if !defined key_noIO
+          IF (ig_def_state(iport) .EQ. ip_ignout) &
+              CALL psmile_write_8(iport,rd_field,kstep)
+#endif
+       ELSE
+!*
+!*    If the user indicated in the namcouple that the field is
+!*    a coupling field then do the import :
+          IF (ig_def_state(iport) .NE. ip_output .AND. &
+               ig_def_state(iport) .ne. ip_input) THEN
+!
+!*       Check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!     
+             DO ip=1,myport(5,iport)
+!     
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - kstep / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+!*   Implementation with "blocking" receives : the program will wait
+!*   indefinitely until a message is received (this may generate a
+!*   deadlock if all models are waiting on a receive).
+!*   However this method will be more efficient in most cases than the
+!*   receives with a time-out loop. 
+!     
+#ifdef __DEBUG
+!
+!jl
+!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
+!jl exist in the network  (2004-04-28)
+!jl
+                CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                ' comm = ',mpi_comm,' result is : ',iflag
+                call flush(nulprt)
+
+                IF (.NOT.iflag) THEN
+                   icount = 0
+   WAITLOOP:       DO
+                   CALL  MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
+                   icount = icount + 1
+                   IF ( iflag ) EXIT WAITLOOP
+                   IF ( icount .GE. icountmax ) THEN
+                      WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
+                      ' still negative after ',icountmax,' seconds : Abort the job'
+                      call flush(nulprt)
+                      CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+                   ENDIF
+                   call sleep(1)
+                   END DO WAITLOOP
+                   WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
+                   call flush(nulprt)
+                ENDIF
+!jl
+#endif
+                CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
+                     itid, itag, mpi_comm, istatus, info )
+                CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
+                     info )
+!     
+                IF ( info .EQ. CLIM_ok  .AND.  imaxbyt .GT. 0) THEN
+                   ilgb = 0
+                   iposbuf = 0
+                   DO is=1,iseg
+                      ioff = mylink(4+2*is-1,ilk) + 1
+                      il_len = mylink(4+2*is,ilk)
+!     
+!                      IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double ) THEN
+                      IF ( ityp .EQ. PRISM_Real ) THEN
+                         CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
+                              iposbuf, rd_field(ioff), il_len, &
+                              MPI_DOUBLE_PRECISION, mpi_comm, info)
+                      ELSE
+                         WRITE(nulprt,*)'Get - pb type incorrect ',ityp
+                         kinfo = CLIM_BadType
+                         GO TO 1010
+                      ENDIF
+                      ilgb = ilgb + il_len
+                   ENDDO
+                   IF (ilgb*ibyt .le. imaxbyt) THEN
+                      irecv  = irecv + 1
+                      nbrecv = nbrecv + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
+                           'Get - <from:',imod, &
+                           '> <step:',kstep, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag,'>' 
+                   ELSE
+                      kinfo = CLIM_Unpack
+                      WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
+                           info,'>'
+                      GO TO 1010
+                   ENDIF
+                ELSE
+                   kinfo = CLIM_TimeOut
+                   WRITE(nulprt,FMT='(A,I3,A)') &
+                        'Get - abnormal exit from trecv <mpi ',info,'>'
+                   GO TO 1010
+                ENDIF
+! 
+             ENDDO
+!     
+             WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
+!
+#if !defined key_noIO
+             IF (ig_def_state(iport) .eq. ip_expout .or. &
+                  ig_def_state(iport) .eq. ip_ignout) &
+!
+!*    If the user indicated in the namcouple that the field must be written 
+!*     to file, do the writing here :
+!
+                call psmile_write_8(iport,rd_field,kstep) 
+#endif
+         ENDIF
+          rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), &
+               size(rd_field_2d,2)/)) 
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_get_proto_r28
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** READ_FILE ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, reads input fields from binary files or 
+!        netcdf files.
+!
+!     interface:
+!     ----------
+!        inp_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE read_filer4(inp_fld, cd_port,id_port)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model     
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+    include 'netcdf.inc'
+!     ----------------------------------------------------------------
+    INTEGER(kind=ip_intwp_p) :: id_port
+    REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port)) 
+    CHARACTER(len=8) :: cd_port
+!     ----------------------------------------------------------------
+    INTEGER(kind=ip_intwp_p) il_unit
+    INTEGER(kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus
+    LOGICAL ll_file
+!     ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Read_File '
+!
+!*    Test if restart file is in NETCDF format or not
+!
+    IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+       istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_GET_VAR_REAL (il_ncid, il_varid, inp_fld)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_CLOSE(il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+    ELSE
+!
+!* Case binary format
+!
+       il_unit = nulprt + 1 
+       INQUIRE (il_unit,OPENED = ll_file)
+       DO WHILE (ll_file)
+          il_unit = il_unit + 1 
+          INQUIRE (il_unit,OPENED = ll_file)
+       END DO
+       OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
+       CALL locreadr4(cd_port,inp_fld,myport(4,id_port),il_unit, &
+            ierror, nulprt)
+       CLOSE (il_unit)
+    ENDIF
+  END SUBROUTINE read_filer4
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** READ_FILE ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, reads input fields from binary files or 
+!        netcdf files.
+!
+!     interface:
+!     ----------
+!        inp_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE read_filer8(inp_fld, cd_port,id_port)
+!     ---------------------------------------------------------------- 
+    USE mod_kinds_model    
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+    include 'netcdf.inc'
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p) :: id_port
+    REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port)) 
+    CHARACTER(len=8) :: cd_port
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p) il_unit
+    INTEGER (kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus
+    LOGICAL ll_file
+!     ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Read_File '
+!
+!*    Test if restart file is in NETCDF format or not
+!
+    IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+       istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_GET_VAR_DOUBLE (il_ncid, il_varid, inp_fld)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+       istatus = NF_CLOSE(il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_get routine '
+          STOP
+       ENDIF
+    ELSE
+!
+!* Case binary format
+!
+       il_unit = nulprt + 1 
+       INQUIRE (il_unit,OPENED = ll_file)
+       DO WHILE (ll_file)
+          il_unit = il_unit + 1 
+          INQUIRE (il_unit,OPENED = ll_file)
+       END DO
+       OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
+       CALL locreadr8(cd_port,inp_fld,myport(4,id_port),il_unit, &
+            ierror, nulprt)
+       CLOSE (il_unit)
+    ENDIF
+  END SUBROUTINE read_filer8
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** READ_FILE_PARA ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, reads input fields from binary files or 
+!        netcdf files.
+!
+!     interface:
+!     ----------
+!        inp_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE read_file_parar4(inp_fld, cd_port, id_port)
+!     ---------------------------------------------------------------- 
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+#include <netcdf.inc>
+#include <mpif.h>
+!     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) :: id_port
+      CHARACTER(len=8) :: cd_port
+      REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port))
+!     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100
+      INTEGER (kind=ip_intwp_p) il_unit
+      INTEGER (kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf, il_aux
+      INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len
+      INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
+      INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
+      REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work
+      REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
+      LOGICAL ll_file
+      INTEGER(kind=ip_intwp_p)::il_sndreq
+!     ----------------------------------------------------------------
+      WRITE(nulprt,*)'Entering Read_File_Para '
+      istatus(:)=0
+!
+!* Each process of local communicator sends his decomposition to master proc
+!  
+      CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
+           ip_tag, ig_local_comm, ierror )
+      CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
+           ip_tag+1, ig_local_comm, ierror )
+!
+!* Master proc receives each process decomposition
+!
+      IF (mpi_rank.eq.0) THEN
+         il_maxgrd = 0
+         ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
+         il_paral_mast(:,:)=0
+         DO ib = 0, kbcplproc(ig_mynummod)-1
+            CALL MPI_Recv (il_paral_mast(:,ib+1), &
+                 CLIM_Parsize, MPI_INTEGER, ib, &
+                 ip_tag, ig_local_comm, istatus, ierror )
+             CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
+                 ip_tag+1, ig_local_comm, istatus, ierror )
+             il_maxgrd = il_maxgrd + il_aux
+         END DO
+         il_maxbyte = il_maxgrd * 4
+      ENDIF
+      ALLOCATE(rl_work(myport(4,id_port)))
+      IF (mpi_rank.eq.0) THEN
+         ALLOCATE (rl_start(il_maxgrd))
+         ALLOCATE(rl_work_mast(il_maxgrd))
+         rl_start(:)=0
+         rl_work_mast(:)=0
+!
+!* Test if restart file is in NETCDF format or not
+!
+         IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+            il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, &
+                 il_ncid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_GET_VAR_REAL (il_ncid, il_varid, rl_start)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_put routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_CLOSE(il_ncid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+         ELSE
+!
+!* Case binary format
+!
+            il_unit = nulprt + 1
+            INQUIRE (il_unit,OPENED = ll_file)
+            DO WHILE (ll_file)
+               il_unit = il_unit + 1 
+               INQUIRE (il_unit,OPENED = ll_file)
+            END DO
+            OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
+            CALL locreadr4(cd_port,rl_start,il_maxgrd,il_unit, &
+                 ierror, nulprt) 
+!     
+            CLOSE (il_unit)
+         ENDIF
+!
+!* Master proc sends to each proc his part of the field
+!
+         DO ib = kbcplproc(ig_mynummod)- 1,0,-1
+            iposbuf=0
+            DO ib_aux=1,il_paral_mast(clim_segments,ib+1)
+               il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1
+               il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1)            
+               call MPI_Pack(rl_start(il_off:il_off+il_len-1), &
+                    il_len,MPI_REAL,rl_work_mast,il_maxbyte, &
+                    iposbuf, ig_local_comm, ierror)
+            END DO
+            IF(ib.GT.0) THEN
+            CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
+                 ip_tag+2, ig_local_comm, ierror )
+            ELSE
+            CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
+                 ip_tag+2, ig_local_comm,il_sndreq, ierror )
+            ENDIF
+         ENDDO
+         DEALLOCATE (il_paral_mast)
+         DEALLOCATE (rl_work_mast)
+         DEALLOCATE (rl_start)
+      ENDIF
+!
+!* Each proc receives his part of the field
+!      
+      call MPI_Recv ( rl_work, myport(4,id_port)*4, MPI_PACKED, 0, &
+           ip_tag+2, ig_local_comm, istatus, ierror )
+      iposbuf=0
+      il_off=1
+      il_len=myport(4,id_port) 
+      CALL MPI_Unpack(rl_work, myport(4,id_port)*4,iposbuf, &
+           inp_fld(il_off:il_off+il_len-1), &
+           il_len, MPI_REAL, ig_local_comm, ierror)
+      IF (mpi_rank.eq.0) THEN
+         call MPI_Wait(il_sndreq,istatus,ierror)
+      ENDIF
+      DEALLOCATE(rl_work)
+    END SUBROUTINE read_file_parar4
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** READ_FILE_PARA ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, reads input fields from binary files or 
+!        netcdf files.
+!
+!     interface:
+!     ----------
+!        inp_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE read_file_parar8(inp_fld, cd_port, id_port)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model     
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+#include <netcdf.inc>
+#include <mpif.h>
+!     ----------------------------------------------------------------
+      CHARACTER(len=8) :: cd_port
+      INTEGER(kind=ip_intwp_p) :: id_port
+      REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port))
+!     ----------------------------------------------------------------
+      INTEGER(kind=ip_intwp_p),PARAMETER :: ip_tag=100
+      INTEGER(kind=ip_intwp_p) il_unit, il_aux
+      INTEGER(kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf
+      INTEGER(kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len
+      INTEGER(kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
+      INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
+      REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work
+      REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
+      LOGICAL ll_file
+      INTEGER(kind=ip_intwp_p)::il_sndreq
+!     ----------------------------------------------------------------
+      WRITE(nulprt,*)'Entering Read_File_Para '
+      istatus(:)=0
+!
+!* Each process of local communicator sends his decomposition to master proc
+!  
+      CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
+           ip_tag, ig_local_comm, ierror )
+      CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
+           ip_tag+1, ig_local_comm, ierror )
+!
+!* Master proc receives each process decomposition
+!
+      IF (mpi_rank.eq.0) THEN
+         il_maxgrd = 0
+         ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
+         il_paral_mast(:,:)=0
+         DO ib = 0, kbcplproc(ig_mynummod)-1
+            CALL MPI_Recv (il_paral_mast(:,ib+1), &
+                 CLIM_Parsize, MPI_INTEGER, ib, &
+                 ip_tag, ig_local_comm, istatus, ierror )
+            CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
+                 ip_tag+1, ig_local_comm, istatus, ierror )
+            il_maxgrd = il_maxgrd + il_aux
+         END DO
+         il_maxbyte = il_maxgrd * 8
+      ENDIF
+      ALLOCATE(rl_work(myport(4,id_port)))
+      rl_work(:)=0
+      IF (mpi_rank.eq.0) THEN
+         ALLOCATE (rl_start(il_maxgrd))
+         ALLOCATE(rl_work_mast(il_maxgrd))
+         rl_start(:)=0
+         rl_work_mast(:)=0
+!
+!* Test if restart file is in NETCDF format or not
+!
+         IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+            il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, &
+                 il_ncid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_GET_VAR_DOUBLE (il_ncid, il_varid, rl_start)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_put routine '
+               STOP
+            ENDIF
+            il_status_ncdf = NF_CLOSE(il_ncid)
+            IF (il_status_ncdf.ne.NF_NOERR) THEN
+               WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+               WRITE(nulprt,*)' stop in PRISM_get routine '
+               STOP
+            ENDIF
+         ELSE
+!
+!* Case binary format
+!
+            il_unit = nulprt + 1
+            INQUIRE (il_unit,OPENED = ll_file)
+            DO WHILE (ll_file)
+               il_unit = il_unit + 1 
+               INQUIRE (il_unit,OPENED = ll_file)
+            END DO
+            OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
+            CALL locreadr8(cd_port,rl_start,il_maxgrd,il_unit, &
+                 ierror, nulprt) 
+!     
+            CLOSE (il_unit)
+         ENDIF
+!
+!* Master proc sends to each proc his part of the field
+!
+         DO ib = kbcplproc(ig_mynummod)- 1,0,-1
+            iposbuf=0
+            DO ib_aux=1,il_paral_mast(clim_segments,ib+1)
+               il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1
+               il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1)            
+               call MPI_Pack(rl_start(il_off:il_off+il_len-1), &
+                    il_len,MPI_DOUBLE_PRECISION,rl_work_mast,il_maxbyte, &
+                    iposbuf, ig_local_comm, ierror)
+            END DO
+            IF(ib.GT.0) THEN
+            CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
+                 ip_tag+2, ig_local_comm, ierror )
+            ELSE
+            CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
+                 ip_tag+2, ig_local_comm,il_sndreq, ierror )
+            ENDIF
+         ENDDO
+         DEALLOCATE (il_paral_mast)
+         DEALLOCATE (rl_work_mast)
+         DEALLOCATE (rl_start)
+      ENDIF
+!
+!* Each proc receives his part of the field
+!      
+      call MPI_Recv ( rl_work, myport(4,id_port)*8, MPI_PACKED, 0, &
+           ip_tag+2, ig_local_comm, istatus, ierror )
+      iposbuf=0
+      il_off=1
+      il_len=myport(4,id_port) 
+      CALL MPI_Unpack(rl_work, myport(4,id_port)*8,iposbuf, &
+           inp_fld(il_off:il_off+il_len-1), &
+           il_len, MPI_DOUBLE_PRECISION, ig_local_comm, ierror)
+      IF (mpi_rank.eq.0) THEN
+         call MPI_Wait(il_sndreq,istatus,ierror)
+      ENDIF
+      DEALLOCATE(rl_work)
+    END SUBROUTINE read_file_parar8
+
+!
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+    SUBROUTINE locreadr4 ( cdfldn, pfield, kdimax, knulre, kflgre, kout)
+!
+!**** *locread*  - Read binary field on unit knulre
+!
+!     Purpose:
+!     -------
+!     Find string cdfldn on unit knulre and read array pfield
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)*
+!
+!     Input:
+!     -----
+!                cdfldn : character string locator
+!                kdimax : dimension of field to be read 
+!                knulre : logical unit to be read 
+!                kout   : logical unit to write messages
+!
+!     Output:
+!     ------
+!                pfield : field array (real 1D)
+!                kflgre : error status flag
+!
+!     Reference:
+!     ---------
+!     See OASIS manual (1995) 
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.0       L. Terray      95/09/01  created
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!
+!* ---------------------------- Argument declarations -------------------
+!
+      USE mod_kinds_model
+      INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout
+      REAL(kind=ip_single_p) ::  pfield(kdimax)
+      CHARACTER*8 cdfldn
+!
+!* ---------------------------- Local declarations ----------------------
+!
+      CHARACTER*8 clecfl
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Initialization
+!        --------------
+!
+      WRITE (UNIT = kout,FMT = 1001) knulre
+!
+!* Formats
+!
+1001  FORMAT('Locread : Read binary file connected to unit = ',I4)
+!
+!     2. Find field in file
+!        ------------------
+!
+      REWIND knulre
+200   CONTINUE
+!* Find string
+      READ (UNIT = knulre, ERR = 200, END = 210) clecfl
+      IF (clecfl .NE. cdfldn) GO TO  200
+!* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) pfield
+!* Reading done and ok
+      kflgre = 0
+      GO TO 220
+!* Problem in reading
+210   kflgre = 1
+220   CONTINUE
+!
+!
+!*    3. End of routine
+!        --------------
+!
+      WRITE (UNIT = kout,FMT = *) 'Locread : done'
+      CALL FLUSH (kout)
+      RETURN
+    END SUBROUTINE locreadr4
+
+!
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+    SUBROUTINE locreadr8 ( cdfldn, pfield, kdimax, knulre, kflgre, kout)
+!
+!**** *locread*  - Read binary field on unit knulre
+!
+!     Purpose:
+!     -------
+!     Find string cdfldn on unit knulre and read array pfield
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)*
+!
+!     Input:
+!     -----
+!                cdfldn : character string locator
+!                kdimax : dimension of field to be read 
+!                knulre : logical unit to be read 
+!                kout   : logical unit to write messages
+!
+!     Output:
+!     ------
+!                pfield : field array (real 1D)
+!                kflgre : error status flag
+!
+!     Reference:
+!     ---------
+!     See OASIS manual (1995) 
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.0       L. Terray      95/09/01  created
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!
+!* ---------------------------- Argument declarations -------------------
+!
+      USE mod_kinds_model
+      INTEGER(kind=ip_intwp_p) kdimax, knulre, kflgre, kout
+      REAL(kind=ip_double_p) ::  pfield(kdimax)
+      CHARACTER*8 cdfldn
+!
+!* ---------------------------- Local declarations ----------------------
+!
+      CHARACTER*8 clecfl
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Initialization
+!        --------------
+!
+      WRITE (UNIT = kout,FMT = 1001) knulre
+!
+!* Formats
+!
+1001  FORMAT('Locread : Read binary file connected to unit = ',I4)
+!
+!     2. Find field in file
+!        ------------------
+!
+      REWIND knulre
+200   CONTINUE
+!* Find string
+      READ (UNIT = knulre, ERR = 200, END = 210) clecfl
+      IF (clecfl .NE. cdfldn) GO TO  200
+!* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) pfield
+!* Reading done and ok
+      kflgre = 0
+      GO TO 220
+!* Problem in reading
+210   kflgre = 1
+220   CONTINUE
+!
+!
+!*    3. End of routine
+!        --------------
+!
+      WRITE (UNIT = kout,FMT = *) 'Locread : done'
+      CALL FLUSH (kout)
+      RETURN
+    END SUBROUTINE locreadr8
+
+  END module mod_prism_get_proto
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_grids_writing.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_grids_writing.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_grids_writing.F90	(revision 1677)
@@ -0,0 +1,1119 @@
+#define __VERBOSE
+!-----------------------------------------------------------------------
+! BOP
+!
+! !MODULE:  mod_prism_grids_writing
+! !REMARKS: 
+! !REVISION HISTORY:
+! 2003.07.07 Veronika Gayler initial version
+!
+! !PUBLIC MEMBER FUNCTIONS:
+! 
+!      subroutine prism_start_grids_writing(iwrite)
+!             This subroutine initializes grids writing by receiving a 
+!             starting command from OASIS.
+!
+!      subroutine prism_write_grid(cgrid, nx, ny, lon, lat)
+!	      This subroutine writes longitudes and latitudes for a model
+!             grid.
+!
+!      subroutine prism_write_corner(cgrid, nx, ny, nc, clon, clat)
+!	      This subroutine writes the longitudes and latitudes of the
+!             grid cell corners.
+!
+!      subroutine prism_write_mask(cgrid, nx, ny, mask)
+!	      This subroutine writes the mask for a model grid
+!
+!      subroutine prism_write_area(cgrid, nx, ny, area)
+!	      This subroutine writes the grid cell areas for a model grid.
+!
+!      subroutine prism_terminate_grids_writing()
+!             This subroutine terminates grids writing by sending a flag
+!             to OASIS, stating the all needed grid information was written.
+!       
+
+MODULE mod_prism_grids_writing
+
+! !USES:
+  USE mod_kinds_model
+  USE mod_comprism_proto
+  
+  IMPLICIT NONE
+#include <mpif.h>
+  
+  INTEGER(kind=ip_intwp_p), PARAMETER :: itagcol=9876
+  INTEGER(kind=ip_intwp_p)  :: tag          ! MPI message tag
+  INTEGER(kind=ip_intwp_p)  :: len          ! MPI message length
+  INTEGER(kind=ip_intwp_p)  :: type         ! MPI message type
+  LOGICAL        :: gridswrite      ! grid writing is needed
+  LOGICAL        :: netcdf          ! grids file format is netCDF
+  CHARACTER*5    :: cgrdnam         ! grids file name
+  CHARACTER*5    :: cmsknam         ! masks file name
+  CHARACTER*5    :: csurnam         ! areas file name
+  CHARACTER*4    :: cglonsuf        ! suffix for longitudes
+  CHARACTER*4    :: cglatsuf        ! suffix for latitudes
+  CHARACTER*4    :: crnlonsuf       ! suffix for longitudes
+  CHARACTER*4    :: crnlatsuf       ! suffix for latitudes
+  CHARACTER*4    :: cmsksuf         ! suffix for masks
+  CHARACTER*4    :: csursuf         ! suffix for areas
+!---------------------------------------------------------------------------
+
+CONTAINS
+
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_start_grids_writing(iwrite)
+!--------------------------------------------------------------------------
+! Routine to start the grids writing. To syncronize access to the
+! grids file all component models have to wait for the starting 
+! message from OASIS (via MPI; see prism_init_comp_proto)
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+  
+    INTEGER(kind=ip_intwp_p), INTENT (OUT) :: iwrite ! flag to state whether
+                                            ! grids file needs to be written
+    INTEGER(kind=ip_intwp_p) :: source   ! rank of the sending process
+    INTEGER(kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: status
+
+!--------------------------------------------------------------------------
+
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_start_grids_writing'
+    CALL FLUSH(nulprt)
+#endif
+!
+!-- Initialisation
+!
+    netcdf = .true.
+    gridswrite = .false.
+    iwrite = 0
+    cgrdnam = '-----'
+    cmsknam = '-----'
+    csurnam = '-----'
+    cglonsuf = '----'
+    cglatsuf = '----'
+    crnlonsuf = '----'
+    crnlatsuf = '----'
+    cmsksuf = '----'
+    csursuf = '----'
+    source = 0            ! OASIS: process 0 of global communicator
+
+    IF (grids_start == 1) THEN
+       gridswrite = .true.
+!
+!--    receive grid file name
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - cgrdnam'
+       len = 5
+       type = MPI_CHARACTER
+       tag = itagcol+4
+       CALL MPI_Recv (cgrdnam, len, type, source, tag, mpi_comm, status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len,  &
+               '> <type:',type,'> <tag:',tag,'> ::  ',cgrdnam
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving cgrdnam'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive masks file name
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - cmsknam'
+       len = 5
+       type = MPI_CHARACTER
+       tag = itagcol+5
+       CALL MPI_Recv (cmsknam, len, type, source, tag, mpi_comm, status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len,  &
+               '> <type:',type,'> <tag:',tag,'> ::  ',cmsknam
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving cmsknam'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive areas file name
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - csurnam'
+       len = 5
+       type = MPI_CHARACTER
+       tag = itagcol+6
+       CALL MPI_Recv (csurnam, len, type, source, tag, mpi_comm, status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',csurnam
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving csurnam'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for longitudes
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - cglonsuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+7
+       CALL MPI_Recv (cglonsuf, len, type, source, tag, mpi_comm,status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',cglonsuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving cglonsuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for latitudes
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - cglatsuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+8
+       CALL MPI_Recv (cglatsuf, len, type, source, tag, mpi_comm,status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',cglatsuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving cglatsuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for longitudes of grid cell corners
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - crnlonsuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+9
+       CALL MPI_Recv (crnlonsuf, len, type, source, tag, mpi_comm,status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',crnlonsuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving crnlonsuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for latitudes
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - crnlatsuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+10
+       CALL MPI_Recv (crnlatsuf, len, type, source, tag, mpi_comm,status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',crnlatsuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving crnlatsuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for masks
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - cmsksuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+11
+       CALL MPI_Recv (cmsksuf, len, type, source, tag, mpi_comm, status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',cmsksuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving cmsksuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+!
+!--    receive suffix for areas
+!
+       WRITE (nulprt,FMT='(A)') 'Recv - csursuf'
+       len = 4
+       type = MPI_CHARACTER
+       tag = itagcol+12
+       CALL MPI_Recv (csursuf, len, type, source, tag, mpi_comm, status,mpi_err)
+       IF (mpi_err == MPI_SUCCESS) THEN 
+          WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') &
+               'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, &
+               '> <type:',type,'> <tag:',tag,'> ::  ',csursuf
+          CALL FLUSH(nulprt)
+       ELSE
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'start_grids_writing: error receiving csursuf'
+          WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 
+          WRITE (nulprt,*) 'start_grids_writing: STOP'
+          STOP
+       ENDIF
+
+#ifdef __VERBOSE
+       WRITE (nulprt,*) ' '
+       WRITE (nulprt,*) '  grids file name:              ', cgrdnam
+       WRITE (nulprt,*) '  masks file name:              ', cmsknam
+       WRITE (nulprt,*) '  areas file name:              ', csurnam
+       WRITE (nulprt,*) '  suffix for longitudes:        ', cglonsuf
+       WRITE (nulprt,*) '  suffix for latitudes:         ', cglatsuf
+       WRITE (nulprt,*) '  suffix for corner longitudes: ', crnlonsuf
+       WRITE (nulprt,*) '  suffix for corner latitudes:  ', crnlatsuf
+       WRITE (nulprt,*) '  suffix for masks:             ', cmsksuf
+       WRITE (nulprt,*) '  suffix for areas:             ', csursuf
+       CALL FLUSH(nulprt)
+#endif
+
+   ELSE IF (grids_start == 0) THEN
+!
+!--     grids file already exists, no writing needed
+!
+#ifdef __VERBOSE
+       WRITE (nulprt,*) '  grids file exists, no writing needed'
+       CALL FLUSH(nulprt)
+#endif
+       gridswrite = .false.
+    ELSE
+       WRITE (nulprt,*) ' '
+       WRITE (nulprt,*) 'start_grids_writing: no valid flag received'
+       WRITE (nulprt,*) 'start_grids_writing: grids_start= ', grids_start 
+       WRITE (nulprt,*) 'start_grids_writing: STOP'
+       STOP         
+    ENDIF
+
+    IF (gridswrite) THEN
+       iwrite = 1
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_start_grids_writing'
+    write(nulprt,*) ''
+    CALL FLUSH(nulprt)
+#endif
+    RETURN
+
+  END SUBROUTINE prism_start_grids_writing
+
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_write_grid(cgrid, nx, ny, lon, lat)
+!--------------------------------------------------------------------------
+! Routine to create a new grids file or to add a grid description to an
+! existing grids file.
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+
+    INCLUDE 'netcdf.inc'
+
+    CHARACTER*4,              INTENT (IN) :: cgrid      ! grid acronym
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx         ! number of longitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny         ! number of latitudes
+    REAL(kind=ip_realwp_p),   INTENT (IN) :: lon(nx,ny) ! longitudes
+    REAL(kind=ip_realwp_p),   INTENT (IN) :: lat(nx,ny) ! latitudes
+
+    INTEGER(kind=ip_intwp_p) :: iost         ! i/o status
+    INTEGER(kind=ip_intwp_p) :: nulgrd       ! logical unit of grids file
+    INTEGER(kind=ip_intwp_p) :: stat         ! netcdf status
+    INTEGER(kind=ip_intwp_p) :: ncid         ! netcdf file id
+    INTEGER(kind=ip_intwp_p) :: idx, idy     ! netcdf dimension ids
+    INTEGER(kind=ip_intwp_p) :: idlon, idlat ! netcdf variable ids
+    INTEGER(kind=ip_intwp_p) :: dims(2)      ! netcdf variable dimensions
+
+    LOGICAL :: existent    !true if grids file is already existing
+    LOGICAL :: grdopen     !true if grids file is opened
+
+    CHARACTER*8 :: clon    !locator sring (binary) / variable name (netcdf)
+    CHARACTER*8 :: clat    !locator sring (binary) / variable name (netcdf)
+    
+!--------------------------------------------------------------------------
+
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_write_grid'
+    write(nulprt,*) '  grid acronym: ', cgrid
+    CALL FLUSH(nulprt)
+#endif
+!
+!-- Return, if grids files already exists
+!
+    IF (.NOT. gridswrite) THEN
+       write(nulprt,*) ' '
+       write(nulprt,*) 'No grid writing needed'
+       RETURN
+    ENDIF
+
+    IF (netcdf) THEN
+!      -------------
+!--    netCDF format
+!      -------------
+!
+!      open grids file
+!      ---------------
+       stat = NF_OPEN(cgrdnam//'.nc', NF_WRITE, ncid)
+       IF (stat /= NF_NOERR) THEN
+           stat = NF_CREATE(cgrdnam//'.nc', NF_CLOBBER, ncid)
+          IF (stat /= NF_NOERR) THEN
+             WRITE (nulprt,*) 'prism_write_grid: error opening grids file.'
+             WRITE (nulprt,*) 'prism_write_grid: STOP'
+             STOP
+          ENDIF
+       ENDIF
+!
+!--   define dimensions
+!     -----------------
+      stat = NF_REDEF(ncid)
+      stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx)
+      IF (stat .NE. NF_NOERR) THEN
+          stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx)
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid
+          ENDIF
+      ELSE
+          WRITE(nulprt,*)'Grid already defined: ', cgrid
+          RETURN
+      ENDIF
+      stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy)
+      IF (stat /= NF_NOERR) THEN
+          WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid
+      ENDIF
+
+      dims(1) = idx
+      dims(2) = idy
+! 
+!--   define longitudes
+!     -----------------
+      clon=cgrid//cglonsuf
+      stat = NF_DEF_VAR (ncid, clon , NF_DOUBLE, 2, dims, idlon)
+      IF (stat /= NF_NOERR) THEN
+          WRITE (nulprt,*) 'ERROR defining variable ', clon
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid,idlon,'long_name',18,'Longitudes of '//cgrid)
+      IF (stat /= NF_NOERR) THEN
+          WRITE (nulprt,*) 'ERROR creating att. for longitudes of ', cgrid
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idlon, 'units', 8, 'degree_E')
+      IF (stat /= NF_NOERR) THEN
+          WRITE (nulprt,*) 'ERROR creating att. for longitudes of ', cgrid
+      ENDIF
+!
+!--   define latitudes
+!     ---------------- 
+      clat=cgrid//cglatsuf
+      stat = NF_DEF_VAR (ncid, clat , NF_DOUBLE, 2, dims, idlat)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining variable ', clat
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idlat,'long_name',17,'Latitudes of '//cgrid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for latitudes of ', cgrid
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idlat, 'units', 8, 'degree_N')
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for latitudes of ', cgrid
+      ENDIF
+!
+!--   switch to data mode
+!     -------------------
+      stat = NF_ENDDEF(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode'
+      ENDIF
+!
+!--   write longitudes
+!     ----------------
+      stat = NF_PUT_VAR_DOUBLE (ncid, idlon, lon(:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing lonitudes of ', cgrid
+      ENDIF
+!
+!--   write latitudes
+!     ---------------
+      stat = NF_PUT_VAR_DOUBLE (ncid, idlat, lat(:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing latitudes of ', cgrid
+      ENDIF
+!
+!--   close grids file
+!     ----------------
+      stat = NF_CLOSE(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR closing file', cgrdnam
+      ENDIF
+      
+    ELSE
+!      -------------
+!--    binary format
+!      -------------
+!
+!      open grids file
+!      ---------------
+       INQUIRE (FILE = cgrdnam, EXIST = existent, OPENED = grdopen)
+       IF (existent .AND. grdopen) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_grid: grids file already opened'
+          WRITE (nulprt,*) 'prism_write_grid: STOP'
+          STOP     
+       ENDIF
+       iost = 0
+       nulgrd = 7
+       INQUIRE (nulgrd,OPENED = grdopen)
+       DO WHILE (grdopen)
+          nulgrd = nulgrd + 1 
+          INQUIRE (nulgrd,OPENED = grdopen)
+       END DO
+
+       OPEN (UNIT=nulgrd, FILE=cgrdnam, STATUS='UNKNOWN',                 &
+             ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND',  &
+             ACTION='WRITE', IOSTAT=iost, ERR=110)
+
+110    CONTINUE
+       IF (iost /= 0) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_grid: Error opening grids file'
+          WRITE (nulprt,*) 'prism_write_grid: STOP'
+          STOP
+       ENDIF
+
+!      write longitudes
+!      ----------------
+       clon=cgrid//cglonsuf
+       WRITE (UNIT = nulgrd) clon
+       WRITE (UNIT = nulgrd) lon(:,:)
+                           
+!      write latitudes     
+!      ----------------    
+       clat=cgrid//cglatsuf
+       WRITE (UNIT = nulgrd) clat
+       WRITE (UNIT = nulgrd) lat(:,:)
+
+!      close grids file
+!      ----------------
+       CLOSE (nulgrd)
+
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_write_grid'
+    CALL FLUSH(nulprt)
+#endif
+
+    RETURN
+
+  END SUBROUTINE prism_write_grid
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_write_corner(cgrid, nx, ny, nc, clon, clat)
+!--------------------------------------------------------------------------
+! Routine to add longitudes and latitudes of grid cell corners to an
+! existing grids file.
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+
+    INCLUDE 'netcdf.inc'
+
+    CHARACTER*4,              INTENT (IN) :: cgrid  ! grid acronym
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx     ! number of longitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny     ! number of latitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: nc     ! number of corners per cell
+    REAL(kind=ip_realwp_p),   INTENT (IN) :: clon(nx,ny,nc) ! longitudes
+    REAL(kind=ip_realwp_p),   INTENT (IN) :: clat(nx,ny,nc) ! latitudes
+
+    INTEGER(kind=ip_intwp_p) :: stat           ! netcdf status
+    INTEGER(kind=ip_intwp_p) :: ncid           ! netcdf file id
+    INTEGER(kind=ip_intwp_p) :: idx, idy, idc  ! netcdf dimension ids
+    INTEGER(kind=ip_intwp_p) :: idclon, idclat ! netcdf variable ids
+    INTEGER(kind=ip_intwp_p) :: dims(3)        ! netcdf variable dimensions
+
+    CHARACTER*8 :: crnlon    !locator sring (binary) / variable name (netcdf)
+    CHARACTER*8 :: crnlat    !locator sring (binary) / variable name (netcdf)
+    
+!--------------------------------------------------------------------------
+
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_write_corner'
+    write(nulprt,*) '  grid acronym: ', cgrid
+    CALL FLUSH(nulprt)
+#endif
+
+!
+!-- Return, if grids files was written in a former run
+!
+    IF (.NOT. gridswrite) THEN
+       write(nulprt,*) ' '
+       write(nulprt,*) 'No grid writing needed'
+       RETURN
+    ENDIF
+
+    IF (netcdf) THEN
+!      -------------
+!--    netCDF format
+!      -------------
+!
+!      open grids file
+!      ---------------
+       stat = NF_OPEN(cgrdnam//'.nc', NF_WRITE, ncid)
+       IF (stat /= NF_NOERR) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_corner: ERROR'
+          WRITE (nulprt,*) 'prism_write_corner:   grids.nc file does not exist!'
+          WRITE (nulprt,*) 'prism_write_corner:   call prism_write_grid first!'
+          WRITE (nulprt,*) 'prism_write_corner:   STOP'
+          STOP
+       ENDIF
+!
+!--   define corner dimensions
+!     ------------------------
+      stat = NF_REDEF(ncid)
+      stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR finding out dimension id of x_',cgrid
+      ENDIF
+      stat = NF_INQ_DIMID(ncid, 'y_'//cgrid, idy)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR finding out dimension id of y_',cgrid
+      ENDIF
+      stat = NF_DEF_DIM(ncid, 'crn_'//cgrid, nc, idc)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining dimension crn_',cgrid
+      ENDIF
+
+      dims(1) = idx
+      dims(2) = idy
+      dims(3) = idc
+      ig_noc = nc
+! 
+!--   define corner longitudes
+!     ------------------------
+      crnlon=cgrid//crnlonsuf
+      stat = NF_INQ_VARID (ncid, crnlon, idclon)
+      IF (stat .NE. NF_NOERR) THEN
+          stat = NF_DEF_VAR (ncid, crnlon , NF_DOUBLE, 3, dims, idclon)
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR defining variable ', crnlon
+          ENDIF
+          stat = NF_PUT_ATT_TEXT   &
+             (ncid,idclon,'long_name',39,'Longitudes of grid cell corners of '//cgrid)
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR creating att. for corner longitudes of ', cgrid
+          ENDIF
+          stat = NF_PUT_ATT_TEXT(ncid, idclon, 'units', 8, 'degree_E')
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR creating att. for corner longitudes of ', cgrid
+          ENDIF
+      ELSE
+          WRITE(nulprt,*)'Corners already defined: ', cgrid
+          RETURN
+      ENDIF
+!
+!--   define corner latitudes
+!     ----------------------- 
+      crnlat=cgrid//crnlatsuf
+      stat = NF_DEF_VAR (ncid, crnlat , NF_DOUBLE, 3, dims, idclat)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining variable ', crnlat
+      ENDIF
+      stat = NF_PUT_ATT_TEXT   &
+         (ncid, idclat,'long_name',38,'Latitudes of grid cell corners of '//cgrid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for corner latitudes of ', cgrid
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idclat, 'units', 8, 'degree_N')
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for corner latitudes of ', cgrid
+      ENDIF
+!
+!--   switch to data mode
+!     -------------------
+      stat = NF_ENDDEF(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode'
+      ENDIF
+!
+!--   write longitudes
+!     ----------------
+      stat = NF_PUT_VAR_DOUBLE (ncid, idclon, clon(:,:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing corner lonitudes of ', cgrid
+      ENDIF
+!
+!--   write latitudes
+!     ---------------
+      stat = NF_PUT_VAR_DOUBLE (ncid, idclat, clat(:,:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing corner latitudes of ', cgrid
+      ENDIF
+!
+!--   close grids file
+!     ----------------
+      stat = NF_CLOSE(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR closing file', cgrdnam
+      ENDIF
+      
+    ELSE
+!      -------------
+!--    binary format
+!      -------------
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prisn_write_corner: WARNING: '
+          WRITE (nulprt,*) 'prism_write_corner:   Binary format not supported'
+          WRITE (nulprt,*) 'prism_write_corner:   No corners added'
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_write_corner'
+    CALL FLUSH(nulprt)
+#endif
+
+    RETURN
+
+  END SUBROUTINE prism_write_corner
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_write_mask(cgrid, nx, ny, mask)
+!--------------------------------------------------------------------------
+! Routine to create a new masks file or to add a land see mask to an
+! existing masks file.
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+
+    INCLUDE 'netcdf.inc'
+
+    CHARACTER*4,              INTENT (IN) :: cgrid       ! grid acronym
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx          ! number of longitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny          ! number of latitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: mask(nx,ny) ! mask
+
+    INTEGER(kind=ip_intwp_p) :: iost         ! i/o status
+    INTEGER(kind=ip_intwp_p) :: nulmsk       ! logical unit of masks file
+    INTEGER(kind=ip_intwp_p) :: stat         ! netcdf status
+    INTEGER(kind=ip_intwp_p) :: ncid         ! netcdf file id
+    INTEGER(kind=ip_intwp_p) :: idx, idy     ! netcdf dimension ids
+    INTEGER(kind=ip_intwp_p) :: idmsk        ! netcdf variable id
+    INTEGER(kind=ip_intwp_p) :: dims(2)      ! netcdf variable dimensions
+
+    LOGICAL :: existent    !true if masks file is already existing
+    LOGICAL :: mskopen     !true if masks file is opened
+
+    CHARACTER*8 :: cmsk    !locator sring (binary) / variable name (netcdf)
+    
+!--------------------------------------------------------------------------
+
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_write_mask'
+    write(nulprt,*) '  grid acronym: ', cgrid
+    CALL FLUSH(nulprt)
+#endif
+
+!
+!-- Return, if masks files already exists
+!
+    IF (.NOT. gridswrite) THEN
+       write(nulprt,*) ' '
+       write(nulprt,*) 'No mask writing needed'
+       RETURN
+    ENDIF
+
+    IF (netcdf) THEN
+!      -------------
+!--    netCDF format
+!      -------------
+!
+!      open masks file
+!      ---------------
+       stat = NF_OPEN(cmsknam//'.nc', NF_WRITE, ncid)
+       IF (stat /= NF_NOERR) THEN
+           stat = NF_CREATE(cmsknam//'.nc', NF_CLOBBER, ncid)
+          IF (stat /= NF_NOERR) THEN
+             WRITE (nulprt,*) 'prism_write_mask: error opening masks file.'
+             WRITE (nulprt,*) 'prism_write_mask: STOP'
+             STOP
+          ENDIF
+      ENDIF
+!
+!--   define dimensions
+!     -----------------
+      stat = NF_REDEF(ncid)
+      stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx)
+      IF (stat .NE. NF_NOERR) THEN
+          stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx)
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid
+          ENDIF
+      ELSE
+          WRITE(nulprt,*)'Mask already defined: ', cgrid
+          RETURN
+      ENDIF
+      stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid
+      ENDIF
+
+      dims(1) = idx
+      dims(2) = idy
+! 
+!--   define mask
+!     -----------
+      cmsk=cgrid//cmsksuf
+      stat = NF_DEF_VAR (ncid, cmsk , NF_INT, 2, dims, idmsk)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining variable ', cmsk
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid,idmsk,'long_name',12,'Mask of '//cgrid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for mask of ', cgrid
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idmsk, 'units', 1, '1')
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for mask of ', cgrid
+      ENDIF
+!
+!--   switch to data mode
+!     -------------------
+      stat = NF_ENDDEF(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode'
+      ENDIF
+!
+!--   write mask
+!     ----------
+      stat = NF_PUT_VAR_INT (ncid, idmsk, mask(:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing mask of ', cgrid
+      ENDIF
+!
+!--   close masks file
+!     ----------------
+      stat = NF_CLOSE(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR closing file', cmsknam
+      ENDIF
+      
+    ELSE
+!      -------------
+!--    binary format
+!      -------------
+!
+!      open masks file
+!      ---------------
+       INQUIRE (FILE = cmsknam, EXIST = existent, OPENED = mskopen)
+       IF (existent .AND. mskopen) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_mask: masks file already opened'
+          WRITE (nulprt,*) 'prism_write_mask: STOP'
+          STOP     
+       ENDIF
+       iost = 0
+       nulmsk = 7
+       INQUIRE (nulmsk,OPENED = mskopen)
+       DO WHILE (mskopen)
+          nulmsk = nulmsk + 1 
+          INQUIRE (nulmsk,OPENED = mskopen)
+       END DO
+
+       OPEN (UNIT=nulmsk, FILE=cmsknam, STATUS='UNKNOWN',                 &
+             ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND',  &
+             ACTION='WRITE', IOSTAT=iost, ERR=110)
+
+110    CONTINUE
+       IF (iost /= 0) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_mask: Error opening masks file'
+          WRITE (nulprt,*) 'prism_write_mask: STOP'
+          STOP
+       ENDIF
+
+!      write maks
+!      ----------
+       cmsk=cgrid//cmsksuf
+       WRITE (UNIT = nulmsk) cmsk
+       WRITE (UNIT = nulmsk) mask(:,:)
+                           
+!      close grids file
+!      ----------------
+       CLOSE (nulmsk)
+
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_write_mask'
+    CALL FLUSH(nulprt)
+#endif
+
+    RETURN
+
+  END SUBROUTINE prism_write_mask
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_write_area(cgrid, nx, ny, area)
+!--------------------------------------------------------------------------
+! Routine to create a new areas file or to add areas of a grid to an
+! existing areas file.
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+
+    INCLUDE 'netcdf.inc'
+
+    CHARACTER*4,              INTENT (IN) :: cgrid       ! grid acronym
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx          ! number of longitudes
+    INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny          ! number of latitudes
+    REAL(kind=ip_realwp_p),   INTENT (IN) :: area(nx,ny) ! areas
+
+    INTEGER(kind=ip_intwp_p) :: iost         ! i/o status
+    INTEGER(kind=ip_intwp_p) :: nulsrf       ! logical unit of areas file
+    INTEGER(kind=ip_intwp_p) :: stat         ! netcdf status
+    INTEGER(kind=ip_intwp_p) :: ncid         ! netcdf file id
+    INTEGER(kind=ip_intwp_p) :: idx, idy     ! netcdf dimension ids
+    INTEGER(kind=ip_intwp_p) :: idsrf        ! netcdf variable id
+    INTEGER(kind=ip_intwp_p) :: dims(2)      ! netcdf variable dimensions
+
+    LOGICAL :: existent    !true if areas file is already existing
+    LOGICAL :: srfopen     !true if areas file is opened
+
+    CHARACTER*8 :: csrf    !locator sring (binary) / variable name (netcdf)
+    
+!--------------------------------------------------------------------------
+
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_write_area'
+    write(nulprt,*) '  grid acronym: ', cgrid
+    CALL FLUSH(nulprt)
+#endif
+
+!
+!-- Return, if areas files already exists
+!
+    IF (.NOT. gridswrite) THEN
+       write(nulprt,*) ' '
+       write(nulprt,*) 'No areas writing needed'
+       RETURN
+    ENDIF
+
+    IF (netcdf) THEN
+!      -------------
+!--    netCDF format
+!      -------------
+!
+!      open areas file
+!      ---------------
+       stat = NF_OPEN(csurnam//'.nc', NF_WRITE, ncid)
+       IF (stat /= NF_NOERR) THEN
+           stat = NF_CREATE(csurnam//'.nc', NF_CLOBBER, ncid)
+          IF (stat /= NF_NOERR) THEN
+             WRITE (nulprt,*) 'prism_write_area: error opening areas file.'
+             WRITE (nulprt,*) 'prism_write_area: STOP'
+             STOP
+          ENDIF
+       ENDIF
+!
+!--   define dimensions
+!     -----------------
+      stat = NF_REDEF(ncid)
+      stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx)
+      IF (stat .NE. NF_NOERR) THEN
+          stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx)
+          IF (stat /= NF_NOERR) THEN
+              WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid
+          ENDIF
+      ELSE
+          WRITE(nulprt,*)'Areas already defined: ', cgrid
+          RETURN
+      ENDIF
+      stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid
+      ENDIF
+
+      dims(1) = idx
+      dims(2) = idy
+! 
+!--   define areas
+!     ------------
+      csrf=cgrid//csursuf
+      stat = NF_DEF_VAR (ncid, csrf , NF_DOUBLE, 2, dims, idsrf)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR defining variable ', csrf
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid,idsrf,'long_name',13,'Areas of '//cgrid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for areas of ', cgrid
+      ENDIF
+      stat = NF_PUT_ATT_TEXT(ncid, idsrf, 'units', 2, 'm2')
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR creating att. for areas of ', cgrid
+      ENDIF
+!
+!--   switch to data mode
+!     -------------------
+      stat = NF_ENDDEF(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode'
+      ENDIF
+!
+!--   write areas
+!     -----------
+      stat = NF_PUT_VAR_DOUBLE (ncid, idsrf, area(:,:))
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR writing area of ', cgrid
+      ENDIF
+!
+!--   close areas file
+!     ----------------
+      stat = NF_CLOSE(ncid)
+      IF (stat /= NF_NOERR) THEN
+         WRITE (nulprt,*) 'ERROR closing file', csurnam
+      ENDIF
+      
+    ELSE
+!      -------------
+!--    binary format
+!      -------------
+!
+!      open areas file
+!      ---------------
+       INQUIRE (FILE = csurnam, EXIST = existent, OPENED = srfopen)
+       IF (existent .AND. srfopen) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_area: areas file already opened'
+          WRITE (nulprt,*) 'prism_write_area: STOP'
+          STOP     
+       ENDIF
+       iost = 0
+       nulsrf = 7
+       INQUIRE (nulsrf,OPENED = srfopen)
+       DO WHILE (srfopen)
+          nulsrf = nulsrf + 1 
+          INQUIRE (nulsrf,OPENED = srfopen)
+       END DO
+
+       OPEN (UNIT=nulsrf, FILE=csurnam, STATUS='UNKNOWN',                 &
+             ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND',  &
+             ACTION='WRITE', IOSTAT=iost, ERR=110)
+
+110    CONTINUE
+       IF (iost /= 0) THEN
+          WRITE (nulprt,*) ' '
+          WRITE (nulprt,*) 'prism_write_area: Error opening areas file'
+          WRITE (nulprt,*) 'prism_write_area: STOP'
+          STOP
+       ENDIF
+
+!      write areas
+!      -----------
+       csrf=cgrid//csursuf
+       WRITE (UNIT = nulsrf) csrf
+       WRITE (UNIT = nulsrf) area(:,:)
+                           
+!      close areas file
+!      ----------------
+       CLOSE (nulsrf)
+
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_write_area'
+    CALL FLUSH(nulprt)
+#endif
+
+    RETURN
+
+  END SUBROUTINE prism_write_area
+
+!--------------------------------------------------------------------------
+!
+  SUBROUTINE prism_terminate_grids_writing
+!--------------------------------------------------------------------------
+! Routine to terminate the grids writing. Sent a message to OASIS 
+! saying that the model has written all grids and that 
+! the next model can start editing the grids file.
+!--------------------------------------------------------------------------
+    IMPLICIT NONE
+
+    INTEGER(kind=ip_intwp_p) :: grids_done ! flag to state  that grids 
+                                           ! writing is done
+    INTEGER(kind=ip_intwp_p) :: dest       ! rank of the receiving process
+
+!--------------------------------------------------------------------------
+#ifdef __VERBOSE
+    write(nulprt,*) ' '
+    write(nulprt,*) 'Start - - prism_terminate_grids_writing'
+    CALL FLUSH(nulprt)
+#endif
+
+    IF (.NOT. gridswrite) THEN
+       write(nulprt,*) ' '
+       write(nulprt,*) 'call to routine not needed'
+       RETURN
+    ENDIF
+
+    grids_done = 1
+    dest = 0                   ! OASIS: process 0 of global communicator
+
+    WRITE (nulprt,FMT='(A)') 'Send - grids_done'
+    len = 1
+    type = MPI_INTEGER
+    tag = itagcol+13
+    CALL MPI_Send (grids_done, len, type, dest, tag, mpi_comm, mpi_err)
+    IF (mpi_err == MPI_SUCCESS) THEN
+       WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,I1)') &
+            'Send - <dest:',dest,'> <comm:',mpi_comm,'> <len:',len,  &
+            '> <type:',type,'> <tag:',tag,'> ::  ',grids_done
+       CALL FLUSH(nulprt)
+    ELSE
+       WRITE (nulprt,*) ' '
+       WRITE (nulprt,*) 'terminate_grids_writing: an error occured'
+       WRITE (nulprt,*) 'terminate_grids_writing: err= ', mpi_err 
+       WRITE (nulprt,*) 'terminate_grids_writing: STOP'
+       STOP
+    ENDIF
+
+#ifdef __VERBOSE
+    write(nulprt,*) 'End - - prism_terminate_grids_writing'
+    write(nulprt,*) ' '
+    CALL FLUSH(nulprt)
+#endif
+
+    RETURN
+  END SUBROUTINE prism_terminate_grids_writing
+!--------------------------------------------------------------------------
+
+END MODULE mod_prism_grids_writing
+!--------------------------------------------------------------------------
+
+
+     
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_proto.F90	(revision 1677)
@@ -0,0 +1,127 @@
+MODULE mod_prism_proto
+!
+! -- clim.h   18-08-95   Version 2.0   Author: Laurent Terray
+!    ******
+!             26-10-99   Version 2.4   Jean Latour (F.S.E.) MPI-2 support
+!@
+! -- mod_clim_proto.f90  12-06-02  Version 3.0   A. Caubel 
+! --                     20-05-03  added PRISM_Recvd/Sent   S.Legutke
+     
+!    ******************
+!
+!@  Contents : variables related to the CLIM library
+!@  --------
+!@
+!
+  USE mod_kinds_model
+  INTEGER (kind=ip_intwp_p) :: CLIM_MaxTag
+!
+!-----Parameter sizes
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Void = 0  
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_MaxSegments = 338 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_ParSize = 2*CLIM_MaxSegments+2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Clength = 32
+!
+!-----Dimension of buffer for packing / unpacking messages with MPI
+!
+  INTEGER (kind=ip_intwp_p) :: ig_maxtype, ig_maxtype_field, ig_CLIMmax
+!
+!-----Ports status
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_In      = 1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Out     = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_InOut   = 2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_NotDef   = -2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_In      = 1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Out     = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_InOut   = 2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Recvd   = 3 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Sent    = 4 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_LocTrans   = 5
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_ToRest   = 6
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Output   = 7
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_SentOut   = 8
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_ToRestOut   = 9
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_FromRest   = 10
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Input   = 11
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_RecvOut   = 12
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_FromRestOut   = 13
+
+!
+!-----Field status
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_exported  = 1
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_ignored   = 2
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_input     = 3
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_output    = 4
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_expout    = 5
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_ignout    = 6
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_auxilary  = 7
+!
+!----Field local transformation
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_instant = 1
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_average = 2
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_accumul = 3
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_min = 4
+  INTEGER (kind=ip_intwp_p), PARAMETER :: ip_max = 5
+!
+!-----Parallel distribution
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Strategy = 1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Segments = 2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Serial   = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Apple    = 1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Box      = 2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Orange   = 3 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Offset   = 2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Length   = 3 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_SizeX    = 3 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_SizeY    = 4 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_LdX      = 5 
+!
+!-----Datatypes
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Integer = 1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Real    = 4  
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Double  = 8 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Real    = 4  
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Double  = 8 
+!-----Quit parameters
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_ContPvm = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_StopPvm = 1 
+!
+!-----Error Codes
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_MaxCodes  = -22 
+!
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Ok	 = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_Ok	 = 0 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_FastExit  = -1 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_BadName   = -2 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_BadPort   = -3 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_BadType   = -4 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: PRISM_DoubleDef = -5 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_NotStep   = -6 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_IncStep   = -7 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_IncSize   = -8 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_NotClim   = -9 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_TimeOut   = -10 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Pvm       = -11 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_FirstCall = -12 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_PbRoute   = -13 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Group     = -14 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_BadTaskId = -15 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_NoTask    = -16 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_InitBuff  = -17 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Pack      = -18 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Unpack    = -19 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Down      = -20 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_PvmExit   = -21 
+  INTEGER (kind=ip_intwp_p), PARAMETER :: CLIM_Mpi       = -22 
+!
+
+END MODULE mod_prism_proto
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_put_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_put_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_put_proto.F90	(revision 1677)
@@ -0,0 +1,1278 @@
+module mod_prism_put_proto
+#include <psmile_os.h>
+
+  interface prism_put_proto
+     
+#ifndef __NO_4BYTE_REALS
+     module procedure prism_put_proto_r14
+     module procedure prism_put_proto_r24
+#endif
+     module procedure prism_put_proto_r18, &
+                      prism_put_proto_r28
+     
+  end interface
+
+contains
+#ifndef __NO_4BYTE_REALS
+  SUBROUTINE prism_put_proto_r14(id_port_id,kstep,rd_field,kinfo)
+!
+!*    *** PRISM_put ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        give pfield to Oasis or models connected to port id_port_id at the 
+!        time kstep
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Arnaud Caubel  - Fecit (08/02 - created from CLIM_Export)
+!
+!     modified:
+!     ---------
+!        Reiner Vogelsang, SGI,  27 April 2003
+!        - Screening of 4 byte real interfaces in case a of dbl4 compilation.
+!          File has to be preprocessed with -D__SXdbl4.
+!        S. Legutke, MPI-HH M&D,  13 May 2003
+!        - return PRISM_Sent if a field was received
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    USE mathelp_psmile
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)       kstep, kinfo, id_port_id
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)    il_newtime
+    INTEGER (kind=ip_intwp_p)    info, ib
+    INTEGER (kind=ip_intwp_p)	   isend, ip, iport, ilk, iseg, is, ilgb
+    INTEGER (kind=ip_intwp_p)     imod, itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)    iposbuf
+    INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
+    INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
+    REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max)
+    REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
+    CHARACTER(len=80) :: cl_topps, cl_str
+    CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
+!     ----------------------------------------------------------------
+    isend = 0
+    iport = -1
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0.or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN 
+       GOTO 1010
+    ENDIF
+!     
+!   
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user 
+!     in the namcouple at the end of the field 2nd line.
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+       il_newtime = kstep + ig_def_lag(iport)
+    ENDIF
+    
+    IF (iport.lt.0) THEN
+        kinfo = CLIM_BadPort
+        WRITE(nulprt,FMT='(A,A)') &
+           'Put - WARNING - Invalid port out: ', &
+           cports(id_port_id)
+        GO TO 1010
+    ENDIF
+
+    rl_field_aux(:)=0
+    cl_tmp_sopp(:)=' '
+    il_nindex(:)=0
+    rl_tmp_scal(:)=0
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+    lg_dgfield = .false.
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+!   If the user indicated in the namcouple that the field must be
+!   accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
+!   end of the field 2nd line), do the local transformations.
+!
+    IF (ig_def_trans(iport) .EQ. ip_instant) THEN 
+        cl_str = 'inst(ident(X))'
+        rg_field_trans(:,iport) = rd_field (:)
+    ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
+       ig_def_trans(iport) .EQ. ip_accumul .OR. &
+       ig_def_trans(iport) .EQ. ip_min .OR. &
+       ig_def_trans(iport) .EQ. ip_max) THEN
+        IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0
+        il_nbin = myport(4,iport)
+        il_nbout = il_nbin
+        cl_topps = 'ave, inst, t_sum, t_min, t_max'
+        IF (ig_def_trans(iport) .EQ. ip_average) THEN
+            cl_str = 'ave(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 
+            cl_str = 't_sum(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
+            cl_str = 't_min(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
+            cl_str = 't_max(ident(X))'
+        ENDIF
+        CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
+           ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
+      
+        CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
+           ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
+           rl_field_aux)
+
+        IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
+           CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), &
+           rl_field_aux, ig_number(iport))
+        ig_number(iport) = ig_number(iport) + 1
+        IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
+            ig_number(iport) = 0
+            DO ib = 1, myport(4,iport)
+              rd_field(ib) = rg_field_trans(ib,iport)
+            ENDDO
+        ENDIF
+        kinfo = PRISM_LocTrans
+    ENDIF
+!
+!*    Test if field must be written to restart file i.e.
+!*    - current time is time at the end of simulation +
+!*    - lag of current field is greater 0
+!
+    IF (il_newtime.EQ.ig_ntime.AND.ig_def_lag(iport).GT.0) THEN
+!ac
+       IF (ig_def_state(iport) .ne. ip_output) THEN
+!ac
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!
+       IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+          CALL write_filer4(rd_field,cports(iport),iport)
+       ELSE
+          CALL write_file_parar4(rd_field,cports(iport),iport)
+       ENDIF
+       kinfo = PRISM_ToRest
+!ac
+       ENDIF
+!ac
+!    Test if the current time is a coupling (or I/O) time  
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+!ac
+          IF (ig_def_state(iport) .EQ. ip_output ) THEN
+		CALL psmile_write_4(iport,rd_field,il_newtime)
+              	kinfo = PRISM_Output
+	  ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
+        	       ig_def_state(iport) .EQ. ip_ignout) THEN
+		CALL psmile_write_4(iport,rd_field,il_newtime)
+                kinfo = PRISM_ToRestOut
+          ENDIF	
+!ac
+#endif
+      ENDIF
+    ELSE
+!    Test if the current time is a coupling (or I/O) time  
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+!
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+          IF (ig_def_state(iport) .EQ. ip_output .OR. &
+             ig_def_state(iport) .EQ. ip_expout .OR. &
+             ig_def_state(iport) .EQ. ip_ignout) THEN
+              CALL psmile_write_4(iport,rd_field,il_newtime)
+              kinfo = PRISM_Output
+          ENDIF
+#endif
+!*
+!*   If the user indicated in the namcouple that the field is
+!*   a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 
+!*   at the end of the field 1st line),do the export here.
+!*
+          IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+               ig_def_state(iport) .eq. ip_exported .or. &
+               ig_def_state(iport) .eq. ip_ignored .or. &
+               ig_def_state(iport) .eq. ip_ignout .or. &
+               ig_def_state(iport) .eq. ip_auxilary) THEN
+
+!
+!*       check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!
+             DO ip=1,myport(5,iport)
+!
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - il_newtime / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+                ilgb = 0
+                iposbuf = 0
+                DO is=1,iseg
+                   ioff = mylink(4+2*is-1,ilk) * 2 + 1
+                   il_len = mylink(4+2*is,ilk)
+!     
+                   IF ( ityp .EQ. PRISM_Real ) THEN
+                      CALL MPI_Pack ( rd_field(ioff), il_len, &
+                           MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, &
+                           mpi_comm, info )
+                   ELSE
+                      WRITE(nulprt,*)'Put - pb type incorrect ', ityp
+                      kinfo = CLIM_BadType
+                      GO TO 1010
+                   ENDIF
+                   ilgb = ilgb + il_len
+                ENDDO
+                IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
+                   kinfo = CLIM_Pack
+                   WRITE(nulprt,FMT='(A,I3,I8,A)') &
+                        'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
+                ELSE
+!*
+                    IF (lg_clim_bsend) THEN
+!*   Buffered send
+!*   -> if fields are not sent and received in the same order, and
+!*   and on architectures on which MPI_Send is not implemented with a 
+!*   mailbox (e.g. NEC SX5)
+!*
+                        CALL MPI_BSend ( pkwork_field, iposbuf, &
+                        MPI_PACKED, itid, itag, mpi_comm, info )
+                    ELSE
+!*
+!*   Standard blocking send: To be used
+!*   -> if fields are necessarily sent and received in the same order, 
+!*   -> or on architectures on which MPI_Send is implemented with a 
+!*      mailbox (e.g. VPPs); in this case, make sure that your mailbox
+!*      size is large enough.
+!
+                        CALL MPI_Send ( pkwork_field, iposbuf, &
+                           MPI_PACKED, itid, itag, mpi_comm, info )
+!
+                    ENDIF
+!
+                   IF (info.eq.CLIM_ok) THEN
+                      isend = isend + 1
+                      nbsend = nbsend + ilgb * ibyt
+                   WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A,I6,A)') &
+                           'Put - <dest:',imod, &
+                           '> <step:',il_newtime, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag, &
+                           '> <comm:',mpi_comm,'>'
+                   ELSE
+                      kinfo = CLIM_Pvm
+                      WRITE(nulprt,FMT='(A,I3,A)') &
+                           'Put - pb send <mpi ',info,'>'
+                   ENDIF
+                ENDIF
+!     
+             ENDDO
+!
+              IF (kinfo .EQ. PRISM_Output) THEN
+                  kinfo = PRISM_SentOut
+              ELSE
+                  kinfo = PRISM_Sent
+              ENDIF
+
+             WRITE(nulprt,FMT='(A,I3,A)') & 
+                  'Put r14- ',isend,' fields exported'
+         ENDIF
+     ENDIF
+ ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_put_proto_r14
+#endif
+  SUBROUTINE prism_put_proto_r18(id_port_id,kstep,rd_field,kinfo)
+!
+!*    *** PRISM_put ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        give rd_field to Oasis or models connected to port id_port_id at the 
+!        time kstep
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Arnaud Caubel  - Fecit (08/02 - created from CLIM_Export)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    USE mathelp_psmile
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)       kstep, kinfo, id_port_id
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)    il_newtime
+    INTEGER (kind=ip_intwp_p)    info
+    INTEGER (kind=ip_intwp_p)	   isend, ip, iport, ilk, iseg, is, ilgb, &
+         imod, itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)    iposbuf
+    INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
+    INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
+    REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max)
+    REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
+    CHARACTER(len=80) :: cl_topps, cl_str
+    CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
+!     ----------------------------------------------------------------
+    isend = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0.or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN
+       GOTO 1010
+    ENDIF
+!
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user
+!     in the namcouple at the end of the field 2nd line.
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+       il_newtime = kstep + ig_def_lag(iport)
+    ENDIF
+
+    IF (iport.LT.0) THEN
+        kinfo = CLIM_BadPort
+        WRITE(nulprt,FMT='(A,A)') &
+           'Put - WARNING - Invalid port out: ', &
+           cports(id_port_id)
+        GO TO 1010
+    ENDIF
+
+    rl_field_aux(:)=0
+    cl_tmp_sopp(:)=' '
+    il_nindex(:)=0
+    rl_tmp_scal(:)=0
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+    lg_dgfield = .true.
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+!
+!   If the user indicated in the namcouple that the field must be
+!   accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
+!   end of the field 2nd line), do the local transformations.
+!    
+    IF (ig_def_trans(iport) .EQ. ip_instant) THEN 
+        cl_str = 'inst(ident(X))'
+        dg_field_trans(:,iport) = rd_field (:)
+    ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
+       ig_def_trans(iport) .EQ. ip_accumul .OR. &
+       ig_def_trans(iport) .EQ. ip_min .OR. &
+       ig_def_trans(iport) .EQ. ip_max) THEN
+        IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0
+        il_nbin = myport(4,iport)
+        il_nbout = il_nbin
+        cl_topps = 'ave, inst, t_sum, t_min, t_max'
+        IF (ig_def_trans(iport) .EQ. ip_average) THEN
+            cl_str = 'ave(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 
+            cl_str = 't_sum(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
+            cl_str = 't_min(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
+            cl_str = 't_max(ident(X))'
+        ENDIF
+        CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
+           ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
+      
+        CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
+           ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
+           rl_field_aux)
+
+        IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
+           CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), &
+           rl_field_aux, ig_number(iport))
+        ig_number(iport) = ig_number(iport) + 1
+        IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
+            ig_number(iport) = 0
+            DO ib = 1, myport(4,iport)
+              rd_field(ib) = dg_field_trans(ib,iport)
+            ENDDO
+        ENDIF
+        kinfo = PRISM_LocTrans
+    ENDIF
+!
+!*    Test if field must be written to restart file i.e.
+!*    - current time is time at the end of simulation +
+!*    - lag of current field is greater 0
+!
+    IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
+!ac
+       IF (ig_def_state(iport) .ne. ip_output) THEN
+!ac
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!
+        IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+          CALL write_filer8(rd_field,cports(iport),iport)
+        ELSE
+          CALL write_file_parar8(rd_field,cports(iport),iport)
+        ENDIF
+        kinfo = PRISM_ToRest
+!ac
+       ENDIF
+!ac
+!    Test if the current time is a coupling (or I/O) time  
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+!ac
+          IF (ig_def_state(iport) .EQ. ip_output ) THEN
+		CALL psmile_write_8(iport,rd_field,il_newtime)
+              	kinfo = PRISM_Output
+	  ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
+        	       ig_def_state(iport) .EQ. ip_ignout) THEN
+		CALL psmile_write_8(iport,rd_field,il_newtime)
+                kinfo = PRISM_ToRestOut
+          ENDIF	
+!ac
+#endif
+      ENDIF
+    ELSE
+
+!    Test if the current time is a coupling (or I/O) time  
+       IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
+!
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+          IF (ig_def_state(iport) .eq. ip_output .or. &
+               ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .eq. ip_ignout) THEN
+             call psmile_write_8(iport,rd_field,il_newtime)
+              kinfo = PRISM_Output
+          ENDIF
+#endif
+!*
+!*   If the user indicated in the namcouple that the field is
+!*   a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 
+!*   at the end of the field 1st line),do the export here.
+!*
+          IF (ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .eq. ip_exported .or. &
+               ig_def_state(iport) .eq. ip_ignored .or. &
+               ig_def_state(iport) .eq. ip_ignout .or. &
+               ig_def_state(iport) .eq. ip_auxilary) THEN
+
+!
+!*       check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!
+             DO ip=1,myport(5,iport)
+!
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - il_newtime / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+                ilgb = 0
+                iposbuf = 0
+                DO is=1,iseg
+                   ioff = mylink(4+2*is-1,ilk) + 1
+                   il_len = mylink(4+2*is,ilk)
+!     
+!                   IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
+                   IF ( ityp .EQ. PRISM_Real ) THEN
+                      CALL MPI_Pack ( rd_field(ioff), il_len, &
+                           MPI_DOUBLE_PRECISION, pkwork_field, &
+                           ig_maxtype_field, iposbuf, &
+                           mpi_comm, info )
+                   ELSE
+                      WRITE(nulprt,*)'Put - pb type incorrect ', ityp
+                      kinfo = CLIM_BadType
+                      GO TO 1010
+                   ENDIF
+                   ilgb = ilgb + il_len
+                ENDDO
+                IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
+                   kinfo = CLIM_Pack
+                   WRITE(nulprt,FMT='(A,I3,I8,A)') &
+                        'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
+                ELSE
+                    IF (lg_clim_bsend) THEN
+!*
+!*   Buffered send
+!*   -> if fields are not sent and received in the same order, and
+!*   and on architectures on which MPI_Send is not implemented with a 
+!*   mailbox (e.g. NEC SX5)
+!*
+                        CALL MPI_BSend ( pkwork_field, iposbuf, &
+                           MPI_PACKED, itid, itag, mpi_comm, info )
+                    ELSE
+!*
+!*   Standard blocking send: To be used
+!*   -> if fields are necessarily sent and received in the same order, 
+!*   -> or on architectures on which MPI_Send is implemented with a 
+!*      mailbox (e.g. VPPs); in this case, make sure that your mailbox
+!*      size is large enough.
+!
+                        CALL MPI_Send ( pkwork_field, iposbuf, &
+                           MPI_PACKED, itid, itag, mpi_comm, info )
+!
+                    ENDIF
+!
+                   IF (info.eq.CLIM_ok) THEN
+                      isend = isend + 1
+                      nbsend = nbsend + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
+                           'Put - <dest:',imod, &
+                           '> <step:',il_newtime, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                        '> <tag:',itag,'>'
+                   ELSE
+                      kinfo = CLIM_Pvm
+                      WRITE(nulprt,FMT='(A,I3,A)') &
+                           'Put - pb send <mpi ',info,'>'
+                   ENDIF
+                ENDIF
+!     
+             ENDDO
+!     
+              IF (kinfo .EQ. PRISM_Output) THEN
+                  kinfo = PRISM_SentOut
+              ELSE
+                  kinfo = PRISM_Sent
+              ENDIF
+
+             WRITE(nulprt,FMT='(A,I3,A)') & 
+                  'Put r18- ',isend,' fields exported'
+          ENDIF
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_put_proto_r18
+#ifndef __NO_4BYTE_REALS
+  SUBROUTINE prism_put_proto_r24(id_port_id,kstep,rd_field_2d,kinfo)
+!
+!*    *** PRISM_put ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        give pfield to Oasis or models connected to port id_port_id at the 
+!        time kstep
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Arnaud Caubel  - Fecit (08/02 - created from CLIM_Export)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    USE mathelp_psmile
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)       kstep, kinfo, id_port_id
+    REAL(kind=ip_single_p), DIMENSION(:,:) :: rd_field_2d
+!     ----------------------------------------------------------------
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+    
+    INTEGER (kind=ip_intwp_p)    il_newtime
+    INTEGER (kind=ip_intwp_p)    info, ib
+    INTEGER (kind=ip_intwp_p)	 isend, ip, iport, ilk, iseg, is, ilgb
+    INTEGER (kind=ip_intwp_p)    imod, itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)    iposbuf
+    INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
+    INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
+    REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max)
+    REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20
+    REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
+    CHARACTER(len=80) :: cl_topps, cl_str
+    CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
+!     ----------------------------------------------------------------
+    isend = 0
+    iport = -1
+!   
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN
+       GOTO 1010
+    ENDIF
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user
+!     in the namcouple at the end of the field 2nd line.
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+       il_newtime = kstep + ig_def_lag(iport)
+    ENDIF
+
+    IF (iport.lt.0) THEN 
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)') &
+            'Put - WARNING - Invalid port out: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+
+    rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), &
+         (/myport(4,id_port_id)/))
+    rl_field_aux(:)=0
+    cl_tmp_sopp(:)=' '
+    il_nindex(:)=0
+    rl_tmp_scal(:)=0
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+    lg_dgfield = .false.
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+!
+!   If the user indicated in the namcouple that the field must be
+!   accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
+!   end of the field 2nd line), do the local transformations.
+!    
+    IF (ig_def_trans(iport) .EQ. ip_instant) THEN 
+        cl_str = 'inst(ident(X))'
+        rg_field_trans(:,iport) = rd_field (:)
+    ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
+       ig_def_trans(iport) .EQ. ip_accumul .OR. &
+       ig_def_trans(iport) .EQ. ip_min .OR. &
+       ig_def_trans(iport) .EQ. ip_max) THEN
+        IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0
+        il_nbin = myport(4,iport)
+        il_nbout = il_nbin
+        cl_topps = 'ave, inst, t_sum, t_min, t_max'
+        IF (ig_def_trans(iport) .EQ. ip_average) THEN
+            cl_str = 'ave(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 
+            cl_str = 't_sum(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
+            cl_str = 't_min(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
+            cl_str = 't_max(ident(X))'
+        ENDIF
+        CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
+           ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
+     
+        CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
+           ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
+           rl_field_aux)
+
+        IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
+           CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), &
+           rl_field_aux, ig_number(iport))
+        ig_number(iport) = ig_number(iport) + 1
+        IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
+            ig_number(iport) = 0
+            DO ib = 1, myport(4,iport)
+              rd_field(ib) = rg_field_trans(ib,iport)
+            ENDDO
+        ENDIF
+        kinfo = PRISM_LocTrans
+    ENDIF
+!
+!*    Test if field must be written to restart file i.e.
+!*    - current time is time at the end of simulation +
+!*    - lag of current field is greater 0
+!
+    IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
+!ac
+       IF (ig_def_state(iport) .ne. ip_output) THEN
+!ac
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!
+       IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+          CALL write_filer4(rd_field,cports(iport),iport)
+       ELSE
+          CALL write_file_parar4(rd_field,cports(iport),iport)
+       ENDIF
+       kinfo = PRISM_ToRest
+!ac
+       ENDIF
+!ac
+!    Test if the current time is a coupling (or I/O) time  
+       IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
+
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+!ac
+          IF (ig_def_state(iport) .EQ. ip_output ) THEN
+		CALL psmile_write_4(iport,rd_field,il_newtime)
+              	kinfo = PRISM_Output
+	  ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
+        	       ig_def_state(iport) .EQ. ip_ignout) THEN
+		CALL psmile_write_4(iport,rd_field,il_newtime)
+                kinfo = PRISM_ToRestOut
+          ENDIF	
+!ac
+#endif
+       ENDIF
+    ELSE
+!    Test if the current time is a coupling (or I/O) time  
+       IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
+!
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+          IF (ig_def_state(iport) .EQ. ip_output .OR. &
+               ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .EQ. ip_ignout) THEN
+              CALL psmile_write_4(iport,rd_field,il_newtime)
+              kinfo = PRISM_Output
+          ENDIF
+#endif
+!*
+!*   If the user indicated in the namcouple that the field is
+!*   a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 
+!*   at the end of the field 1st line),do the export here.
+!*
+          IF (ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .eq. ip_exported .or. &
+               ig_def_state(iport) .eq. ip_ignored .or. &
+               ig_def_state(iport) .eq. ip_ignout .or. &
+               ig_def_state(iport) .eq. ip_auxilary) THEN
+!
+!*       check for connected ports (in)
+!        ------------------------------
+!
+          WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
+!
+          ityp = myport(2,iport)
+          ibyt = myport(3,iport)
+!
+          DO ip=1,myport(5,iport)
+!
+             ilk  = myport(5+ip,iport)
+             imod = mylink(1,ilk)
+             itid = mylink(2,ilk)
+             itag = mylink(3,ilk) - il_newtime / ig_frqmin
+             iseg = mylink(4,ilk)
+!     
+             ilgb = 0
+             iposbuf = 0
+             DO is=1,iseg
+                ioff = mylink(4+2*is-1,ilk) * 2 + 1
+                il_len = mylink(4+2*is,ilk)
+!     
+                IF ( ityp .EQ. PRISM_Real ) THEN
+                   CALL MPI_Pack ( rd_field(ioff), il_len, &
+                        MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, &
+                        mpi_comm, info )
+                ELSE
+                   WRITE(nulprt,*)'Put - pb type incorrect ', ityp
+                   kinfo = CLIM_BadType
+                   GO TO 1010
+                ENDIF
+                ilgb = ilgb + il_len
+             ENDDO
+             IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
+                kinfo = CLIM_Pack
+                WRITE(nulprt,FMT='(A,I3,I8,A)') &
+                     'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
+             ELSE
+                 IF (lg_clim_bsend) THEN
+!*
+!*   Buffered send
+!*   -> if fields are not sent and received in the same order, and
+!*   and on architectures on which MPI_Send is not implemented with a 
+!*   mailbox (e.g. NEC SX5)
+!*
+                CALL MPI_BSend ( pkwork_field, iposbuf, MPI_PACKED, &
+                   itid, itag, mpi_comm, info )
+                ELSE
+!*
+!*   Standard blocking send: To be used
+!*   -> if fields are necessarily sent and received in the same order, 
+!*   -> or on architectures on which MPI_Send is implemented with a 
+!*      mailbox (e.g. VPPs); in this case, make sure that your mailbox
+!*      size is large enough.
+!
+                CALL MPI_Send ( pkwork_field, iposbuf, MPI_PACKED, &
+                   itid, itag, mpi_comm, info )
+!
+            ENDIF
+!
+                IF (info.eq.CLIM_ok) THEN
+                   isend = isend + 1
+                   nbsend = nbsend + ilgb * ibyt
+                   WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
+                        'Put - <dest:',imod, &
+                        '> <step:',il_newtime, &
+                        '> <len:',ilgb, &
+                        '> <type:',ibyt, &
+                        '> <tag:',itag,'>'
+                ELSE
+                   kinfo = CLIM_Pvm
+                   WRITE(nulprt,FMT='(A,I3,A)') &
+                        'Put - pb send <mpi ',info,'>'
+                ENDIF
+             ENDIF
+!     
+          ENDDO
+! 
+          IF (kinfo .EQ. PRISM_Output) THEN
+              kinfo = PRISM_SentOut
+          ELSE
+              kinfo = PRISM_Sent
+          ENDIF
+
+          WRITE(nulprt,FMT='(A,I3,A)') & 
+               'Put r24- ',isend,' fields exported'
+       ENDIF
+    ENDIF
+ ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+ CALL FLUSH(nulprt)
+ RETURN
+END SUBROUTINE prism_put_proto_r24
+#endif
+  SUBROUTINE prism_put_proto_r28(id_port_id,kstep,rd_field_2d,kinfo)
+!
+!*    *** PRISM_put ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        give rd_field to Oasis or models connected to port id_port_id at the 
+!        time kstep
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 rd_field	: buffer of reals
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Arnaud Caubel  - Fecit (08/02 - created from CLIM_Export)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    USE mathelp_psmile
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)       kstep, kinfo, id_port_id
+    REAL(kind=ip_double_p), DIMENSION(:,:) :: rd_field_2d
+!     ----------------------------------------------------------------
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+    INTEGER (kind=ip_intwp_p)    il_newtime
+    INTEGER (kind=ip_intwp_p)    info
+    INTEGER (kind=ip_intwp_p)	   isend, ip, iport, ilk, iseg, is, ilgb, &
+         imod, itid, itag, il_len, ioff, ityp, ibyt
+    INTEGER (kind=ip_intwp_p)    iposbuf
+    INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
+    INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
+    INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
+    REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max)
+    REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20
+    REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
+    CHARACTER(len=80) :: cl_topps, cl_str
+    CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
+!     ----------------------------------------------------------------
+    isend = 0
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    
+    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN 
+       GOTO 1010
+    ENDIF
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user
+!     in the namcouple at the end of the field 2nd line.
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+       il_newtime = kstep + ig_def_lag(iport)
+    ENDIF
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)') &
+            'Put - WARNING - Invalid port out: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+
+    rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), &
+         (/myport(4,id_port_id)/))
+    rl_field_aux(:)=0
+    cl_tmp_sopp(:)=' '
+    il_nindex(:)=0
+    rl_tmp_scal(:)=0
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+    lg_dgfield = .true.
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+!    isend = 0
+!    iport = -1
+!
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+!    IF (ig_def_freq(id_port_id) .eq. 0 .or. &
+!         ig_def_freq(id_port_id) .gt. ig_ntime) THEN 
+!       GOTO 1010
+!    ENDIF
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user
+!     in the namcouple at the end of the field 2nd line.
+!    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+!       iport=id_port_id
+!       il_newtime = kstep + ig_def_lag(iport)
+!    ENDIF
+!    IF (iport.lt.0) THEN
+!       kinfo = CLIM_BadPort
+!       WRITE(nulprt,FMT='(A,A)') &
+!            'Put - WARNING - Invalid port out: ', &
+!            cports(id_port_id)
+!       GO TO 1010
+!    ENDIF
+!
+!   If the user indicated in the namcouple that the field must be
+!   accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
+!   end of the field 2nd line), do the local transformations.
+!    
+    IF (ig_def_trans(iport) .EQ. ip_instant) THEN 
+        cl_str = 'inst(ident(X))'
+        dg_field_trans(:,iport) = rd_field (:)
+    ELSEIF (ig_def_trans(iport) .EQ. ip_average .OR. &
+       ig_def_trans(iport) .EQ. ip_accumul .OR. &
+       ig_def_trans(iport) .EQ. ip_min .OR. &
+       ig_def_trans(iport) .EQ. ip_max) THEN
+        IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0
+        il_nbin = myport(4,iport)
+        il_nbout = il_nbin
+        cl_topps = 'ave, inst, t_sum, t_min, t_max'
+        IF (ig_def_trans(iport) .EQ. ip_average) THEN
+            cl_str = 'ave(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 
+            cl_str = 't_sum(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
+            cl_str = 't_min(ident(X))'
+        ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
+            cl_str = 't_max(ident(X))'
+        ENDIF
+        CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
+           ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
+      
+        CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
+           ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
+           rl_field_aux)
+
+        IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
+           CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), &
+           rl_field_aux, ig_number(iport))
+        ig_number(iport) = ig_number(iport) + 1
+        IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
+            ig_number(iport) = 0
+            DO ib = 1, myport(4,iport)
+              rd_field(ib) = dg_field_trans(ib,iport)
+            ENDDO
+        ENDIF
+        kinfo = PRISM_LocTrans
+    ENDIF
+!
+!*    Test if field must be written to restart file i.e.
+!*    - current time is time at the end of simulation +
+!*    - lag of current field is greater from 0
+!
+    IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
+!ac
+       IF (ig_def_state(iport) .ne. ip_output) THEN
+!ac
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!
+       IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
+          CALL write_filer8(rd_field,cports(iport),iport)
+       ELSE
+          CALL write_file_parar8(rd_field,cports(iport),iport)
+       ENDIF
+       kinfo = PRISM_ToRest
+!ac
+       ENDIF
+!ac
+!    Test if the current time is a coupling (or I/O) time  
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+!ac
+          IF (ig_def_state(iport) .EQ. ip_output ) THEN
+		CALL psmile_write_8(iport,rd_field,il_newtime)
+              	kinfo = PRISM_Output
+	  ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
+        	       ig_def_state(iport) .EQ. ip_ignout) THEN
+		CALL psmile_write_8(iport,rd_field,il_newtime)
+                kinfo = PRISM_ToRestOut
+          ENDIF	
+!ac
+!          IF (ig_def_state(iport) .EQ. ip_output .OR. &
+!               ig_def_state(iport) .eq. ip_expout .or. &
+!               ig_def_state(iport) .EQ. ip_ignout) THEN
+!              CALL psmile_write_8(iport,rd_field,il_newtime)
+!              kinfo = PRISM_ToRestOut
+!          ENDIF
+#endif
+      ENDIF
+    ELSE
+
+!    Test if the current time is a coupling (or I/O) time  
+       IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
+!
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+          IF (ig_def_state(iport) .EQ. ip_output .OR. &
+               ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .eq. ip_ignout) THEN
+             call psmile_write_8(iport,rd_field,il_newtime)
+             kinfo = PRISM_Output
+         ENDIF
+#endif
+!*
+!*   If the user indicated in the namcouple that the field is
+!*   a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 
+!*   at the end of the field 1st line),do the export here.
+!*
+          IF (ig_def_state(iport) .eq. ip_expout .or. &
+               ig_def_state(iport) .eq. ip_exported .or. &
+               ig_def_state(iport) .eq. ip_ignored .or. &
+               ig_def_state(iport) .eq. ip_ignout .or. &
+               ig_def_state(iport) .eq. ip_auxilary) THEN
+!
+!*       check for connected ports (in)
+!        ------------------------------
+!
+             WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
+!
+             ityp = myport(2,iport)
+             ibyt = myport(3,iport)
+!
+             DO ip=1,myport(5,iport)
+!
+                ilk  = myport(5+ip,iport)
+                imod = mylink(1,ilk)
+                itid = mylink(2,ilk)
+                itag = mylink(3,ilk) - il_newtime / ig_frqmin
+                iseg = mylink(4,ilk)
+!     
+                ilgb = 0
+                iposbuf = 0
+                DO is=1,iseg
+                   ioff = mylink(4+2*is-1,ilk) + 1
+                   il_len = mylink(4+2*is,ilk)
+                   !     
+ !                  IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
+                   IF ( ityp .EQ. PRISM_Real ) THEN
+                     CALL MPI_Pack(rd_field(ioff),il_len, &
+                           MPI_DOUBLE_PRECISION, &
+                           pkwork_field, ig_maxtype_field, iposbuf, &
+                           mpi_comm, info )
+                   ELSE
+                      WRITE(nulprt,*)'Put - pb type incorrect ', ityp
+                      kinfo = CLIM_BadType
+                      GO TO 1010
+                   ENDIF
+                   ilgb = ilgb + il_len
+                ENDDO
+                IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
+                   kinfo = CLIM_Pack
+                   WRITE(nulprt,FMT='(A,I3,I8,A)') &
+                        'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
+                ELSE
+                    IF (lg_clim_bsend) THEN
+!*
+!*   Buffered send
+!*   -> if fields are not sent and received in the same order, and
+!*   and on architectures on which MPI_Send is not implemented with a 
+!*   mailbox (e.g. NEC SX5)
+!*
+                        CALL MPI_BSend ( pkwork_field, iposbuf, &
+                           MPI_PACKED, itid, itag, mpi_comm, info )
+                    ELSE
+!*
+!*   Standard blocking send: To be used
+!*   -> if fields are necessarily sent and received in the same order, 
+!*   -> or on architectures on which MPI_Send is implemented with a 
+!*      mailbox (e.g. VPPs); in this case, make sure that your mailbox
+!*      size is large enough.
+!
+                        CALL MPI_Send ( pkwork_field, iposbuf, &
+                           MPI_PACKED, itid, itag, mpi_comm, info )
+!
+                    ENDIF
+!
+                   IF (info.eq.CLIM_ok) THEN
+                      isend = isend + 1
+                      nbsend = nbsend + ilgb * ibyt
+                      WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
+                           'Put - <dest:',imod, &
+                           '> <step:',il_newtime, &
+                           '> <len:',ilgb, &
+                           '> <type:',ibyt, &
+                           '> <tag:',itag,'>'
+                   ELSE
+                      kinfo = CLIM_Pvm
+                      WRITE(nulprt,FMT='(A,I3,A)') &
+                           'Put - pb send <mpi ',info,'>'
+                   ENDIF
+                ENDIF
+!     
+             ENDDO
+!
+             IF (kinfo .EQ. PRISM_Output) THEN
+                 kinfo = PRISM_SentOut
+             ELSE
+                 kinfo = PRISM_Sent
+             ENDIF
+
+             WRITE(nulprt,FMT='(A,I3,A)') & 
+                  'Put r28 - ',isend,' fields exported'
+          ENDIF
+       ENDIF
+    ENDIF
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_put_proto_r28
+
+end module mod_prism_put_proto
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_date_and_time.f90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_date_and_time.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_date_and_time.f90	(revision 1677)
@@ -0,0 +1,43 @@
+       module mod_psmile_date_and_time
+         USE mod_kinds_model
+!This data structure contains the initial date of the simulation, respectively
+! the experiment.
+!The meanings of the fields are
+!	1	fullyear like 1978
+!	2	month
+!	3	day
+!	4       hour
+!	5	minutes
+!	6	seconds
+
+         integer(kind=ip_intwp_p)::ig_initial_date(1:6)
+         logical::lg_date_is_initialized
+
+       contains
+
+         subroutine psmile_get_initial_date(id_datetime,id_error)
+!------------------------------------------------------------------------
+           USE mod_kinds_model
+           implicit none
+           integer(kind=ip_intwp_p),intent(out)::id_datetime(1:6),id_error
+
+           !This is an initialization for test purposes only
+           ig_initial_date(1)=2002
+           ig_initial_date(2)=11 
+           ig_initial_date(3)=8
+           ig_initial_date(4)=13
+           ig_initial_date(5)=7
+           ig_initial_date(6)=30
+           !End of test initialization
+
+           id_error =0
+
+           if(lg_date_is_initialized) then
+             id_datetime=ig_initial_date
+           else
+             id_error=-999
+           endif
+
+         end subroutine psmile_get_initial_date
+
+       end module mod_psmile_date_and_time
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io.F90	(revision 1677)
@@ -0,0 +1,2041 @@
+#undef __DEBUG
+
+!#define __VERBOSE
+#define __READ_BY_LOOKUP
+!----------------------------------------------------------------------
+! BOP
+!
+! !MODULE:  mod_psmile_io
+! !REMARKS: Initially programed by Reiner Vogelsang, SGI GmbH, and integrated
+!            into OASIS 3.0 and tested by Arnaud Caubel, CERFACS
+!	    Bugs should be reported to reiner@sgi.com or Sophie.Valcke@cerfacs.fr.
+! !REVISION HISTORY:
+! 2003.01.31 Reiner Vogelsang Finalized initial version
+! 2003.02.28 Arnaud Caubel Tests and correction of the READ_BY_LOOKUP
+! 2003.04.24 Reiner Vogelsang Corrections with regard to CF naming convention.
+! 2003.04.28 Reiner Vogelsang Added ProTex documentation header and 
+!                             static CVS versions string.
+! 2004.03.08 Sophie Valcke    Added the writting of bounds,lons and lats.
+! 2004.04.07 Reiner Vogelsang Correction: bounds are written with
+!                             number of corners as leading dimension
+! 2004.19.06 Reiner Vogelsang Considering cyclic boundaries for longitudes.
+!                             which lead to differences between corners
+!                             and bounds by 360 degrees
+! 2004.26.08 Reiner Vogelsang Correction of allocation scheme for arrays
+!                             hosting the longitudes.
+!
+! !PUBLIC MEMBER FUNCTIONS:
+! 
+!       subroutine psmile_io_init_comp(id_error)
+!             This subroutine finds a local communicator for the MPI tasks
+!	      of a model component participating in coupling.
+!
+!       subroutine psmile_def_domains(id_error)
+!	      This subroutine initializes the MPP_IO domains.
+!
+!       subroutine psmile_def_files(id_error)
+!	      This subroutine open files acccording to the kewords
+!
+!       subroutine psmile_def_metadata(id_error)
+!	      This subroutine writes CF metadata or finds a variable according
+!             to CF metadata information.
+!
+!       subroutine psmile_close_files(id_error)
+!             This subroutine closes all opened psmile_io files
+!
+!       subroutine psmile_io_cleanup(id_error)
+!             This subroutine deallocates all PSMILe I/O related data
+!	      and exits MPP_IO
+!
+!       subroutine psmile_read_8(id_port_id,rd_field,id_newtime)
+!	      This subroutine reads REAL(KIND=4) data.
+!
+!       subroutine psmile_read_4(id_port_id,rd_field,id_newtime)
+!	      This subroutine reads REAL(KIND=8) data.
+!
+!       subroutine psmile_write_4(id_port_id,rd_field,id_newtime)
+!	      This subroutine writes REAL(KIND=4) data.
+!
+!       subroutine psmile_write_8(id_port_id,rd_field,id_newtime)
+!	      This subroutine writes REAL(KIND=8) data.
+!
+!       subroutine indexi(n,arr,indx)
+!	      This subroutine sorts by indexing.
+!
+!       subroutine combine_with_date(cd_in,cd_mode,id_initial_date,cd_on)
+!	      This subroutines appends the date in ISO format to a strings. 
+!       
+
+       module mod_psmile_io
+
+! !USES:
+       use mod_kinds_model
+       use mpp_mod
+       use mpp_io_mod
+       use mpp_domains_mod
+! !PUBLIC TYPES:
+!Highest unit number permittable by the OS.
+       integer(kind=ip_intwp_p),parameter::PSMILE_MAX_UNIT=299
+!Highest unit number reserved by the OS.
+       integer(kind=ip_intwp_p),parameter::PSMILE_MAX_RESERVED_UNIT=104
+!Lowest unit number reserved by the OS.
+       integer(kind=ip_intwp_p),parameter::PSMILE_MIN_RESERVED_UNIT=100
+       integer(kind=ip_intwp_p),parameter::PSMILE_MAX_CF_TABLE_ENTRIES=1024
+       integer(kind=ip_intwp_p),allocatable::nbr_corners(:)
+
+       integer(kind=ip_intwp_p)::ig_mpp_io_comm,ig_color,ig_mpp_io_comm_size,ig_mpp_io_comm_rank
+       integer(kind=ip_intwp_p)::ig_stackmax=1310720,ig_stackmaxd=655360
+       integer(kind=ip_intwp_p)::ig_layout(2)
+!Global arrays to specify IO domains
+       type(domain2D),allocatable::domain(:)
+       type(domain1D),allocatable::xdom(:),ydom(:)
+       logical,allocatable::lg_is_odd_distribution(:)
+!Global arrarys for opening files
+       integer(kind=ip_intwp_p),allocatable::ig_units(:)
+       integer(kind=ip_intwp_p),allocatable::ig_action(:)
+       integer(kind=ip_intwp_p),allocatable::ig_form(:)
+       integer(kind=ip_intwp_p),allocatable::ig_threading(:)
+       integer(kind=ip_intwp_p),allocatable::ig_fileset(:)
+       character(len=128),allocatable::cg_my_input_file(:)
+       character(len=128),allocatable::cg_output_file(:)
+
+
+!Global arrays for netcdf metadata informations
+       integer(kind=ip_intwp_p),allocatable::ig_var_index(:)
+       integer(kind=ip_intwp_p),allocatable::ig_ntimes(:)
+!RV: 22.01.2003
+       TYPE time_stamps
+!	    real(kind=ip_double_p),pointer::rl_times(:)
+!AC:31/01
+        real(kind=ip_double_p),dimension(:),pointer :: rl_times  
+       END TYPE time_stamps
+! !PUBLIC DATA MEMBERS:
+       type(time_stamps),allocatable :: dg_times(:)
+
+       type(fieldtype),allocatable::ig_vars(:),field(:),latij(:),lonij(:)
+       type(fieldtype),allocatable::crnlatij(:), crnlonij(:)
+       type(axistype),allocatable::x_axis(:),y_axis(:),z_axis(:),t_axis(:)
+       type(axistype),allocatable::c_axis(:)
+! These arrays are supposed to be part of a different module!
+! However, no information is available in Oasis 3.0. So, let them live here
+! for a while.
+!RV
+       character(len=64),allocatable::cports_lgname(:)
+       character(len=64),allocatable::cports_units(:)
+       character(len=64),allocatable::cfldlab(:),cfunitslab(:)
+!RV
+! !DESCRIPTION:
+! This module contains the global data objects which hold informations for
+! performing I/O on coupled fields and are the glue between routines defined
+! within this file, mod_psmile_io.F90.
+! !EOP
+!-------------------------------------------------------------------------------
+!$Id: mod_psmile_io.F90,v 1.2 2009/01/15 15:10:14 adm Exp $
+!-------------------------------------------------------------------------------
+       end module mod_psmile_io
+
+
+
+       subroutine psmile_io_init_comp(id_error)
+!--------------------------------------------------------------------------
+
+!Routine must be called in prism_init_comp.
+!The assumption is that each process of a model calls prism_init_comp.
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+
+#include <mpif.h>
+
+
+
+!Arguments:
+!Error return code
+       integer(kind=ip_intwp_p),intent(out)::id_error
+
+!Local Variables:
+!Don't touch the following character variable!
+       character(len=80),save::cl_version_string= &
+'$Id: mod_psmile_io.F90,v 1.2 2009/01/15 15:10:14 adm Exp $'
+!
+!Communicator which covers the whole model.
+       integer(kind=ip_intwp_p)::il_local_comm 
+
+       integer(kind=ip_intwp_p)::il_i,il_key
+       integer(kind=ip_intwp_p),allocatable::il_cpl_ranks(:)
+       integer(kind=ip_intwp_p)::ig_local_comm_grp,il_ncplprocs,ig_local_comm_size,il_mynum
+
+       integer(kind=ip_intwp_p)::il_file_unit,il_max_entry_id,il_no_of_entries
+       integer(kind=ip_intwp_p)::il_pos
+       character(len=64)       :: cl_cfname,cl_cfunit
+       logical                 :: ll_exist
+
+
+#ifdef __VERBOSE
+       write(nulprt,*) 'Start - - psmile_io_init_comp'
+#endif
+       id_error=CLIM_OK
+       il_local_comm=ig_local_comm
+
+!Create a communicator which covers all processes of a model invoLved with
+!coupling.
+       il_ncplprocs=kbcplproc(ig_mynummod)
+       allocate(il_cpl_ranks(1:il_ncplprocs))
+
+       do il_i=0,il_ncplprocs-1
+	 il_cpl_ranks(il_i+1)=il_i
+       enddo
+
+       il_key=1
+       call MPI_Comm_rank(il_local_comm,il_mynum,id_error)
+
+!
+!Create a color  by finding the cpl  ranks  in the model communicator.
+!
+       if(ANY(il_cpl_ranks.eq.il_mynum)) then
+         ig_color=1000*ig_mynummod
+       else
+	 ig_color=1
+       endif
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_io_init_comp: rank ',il_mynum,' color ',ig_color
+#endif
+
+!
+!Do the splitting.
+!
+#ifdef __VERBOSE
+       write(nulprt,*) 'psmile_io_init_comp: Communicator splitting'
+#endif
+       call MPI_Comm_split(il_local_comm,ig_color,il_key,ig_mpp_io_comm,id_error)
+       call MPI_Comm_rank(ig_mpp_io_comm,ig_mpp_io_comm_rank,id_error)
+       call MPI_Comm_size(ig_mpp_io_comm,ig_mpp_io_comm_size,id_error)
+
+!
+!Initialize FMS mpp_init,mpp_io,mpp_domains
+!
+       if (ig_color .eq. 1000*ig_mynummod ) then
+#ifdef __VERBOSE
+         write(nulprt,*) 'psmile_io_init_comp: MPP_INIT : Model',ig_mynummod &
+                         ,ig_mpp_io_comm_rank
+#endif
+         call mpp_init(mpp_comm=ig_mpp_io_comm,logfile=trim(cnaprt))
+         call mpp_domains_set_stack_size(ig_stackmaxd)
+!rv
+!rv Oasis 3 uses for the tracefiles the I/O units >= 1000. Since
+!rv mpp_io stores informations regarding to file specs in an array of
+!rv structs that array has to be allocated apropiately.
+!rv maxresunit specifies that the top maxresunits are excluded from the list
+!rv of the files to be closed on mpp_io_exit.
+!rv
+         call mpp_io_init(maxunit=nulprt,maxresunit=25)
+         call mpp_set_stack_size(ig_stackmax)
+       endif
+
+!After this point I assume that I/O routines are called by processes
+!involved with coupling only.
+
+!RV   At this point I am reading the CF name table definitions.
+
+       inquire(file='cf_name_table.txt',exist=ll_exist)
+       if(ll_exist) then
+#ifdef __VERBOSE
+         write(nulprt,*) 'psmile_io_init_comp: Reading CF name table!'
+         call flush(nulprt)
+#endif
+
+         il_file_unit=nulprt+1
+         open(file='cf_name_table.txt' &
+             ,unit=il_file_unit &
+             ,form='formatted' &
+             ,status='old')
+
+         read(unit=il_file_unit,fmt=*,iostat=id_error)
+         read(unit=il_file_unit,fmt=*,iostat=id_error) &
+             il_max_entry_id, il_no_of_entries
+
+         if(id_error.ne.0) then
+           write(nulprt,*) &
+                 'psmile_io_init_comp:cf_name_table.txt:' &
+                ,' Reading of first record failed!'
+           call flush(nulprt)
+           call MPI_Abort(mpi_comm,0,mpi_error)
+         endif
+
+         if(il_max_entry_id.gt.0.and. &
+            il_max_entry_id.le.PSMILE_MAX_CF_TABLE_ENTRIES) then
+
+           allocate(cfldlab(1:il_max_entry_id),STAT=id_error)
+           if(id_error.ne.0) then
+             write(nulprt,*) &
+                  'psmile_io_init_comp: Allocation of cfldlab failed!'
+             call flush(nulprt)
+             call MPI_Abort(mpi_comm,0,mpi_error)
+           endif
+
+           allocate(cfunitslab(1:il_max_entry_id),STAT=id_error)
+           if(id_error.ne.0) then
+             write(nulprt,*) &
+                  'psmile_io_init_comp: Allocation of cfunitslab failed!'
+                  call flush(nulprt)
+             call MPI_Abort(mpi_comm,0,mpi_error)
+            endif
+
+         else
+
+           write(nulprt,*) &
+                 'psmile_io_init_comp:cf_name_table.txt:' &
+                ,'Your max. numlab is out of range !'
+           call flush(nulprt)
+           call MPI_Abort(mpi_comm,0,mpi_error)
+
+         endif
+
+
+         read(unit=il_file_unit,fmt=*,iostat=id_error)
+         do il_i=1,il_no_of_entries
+
+           read(unit=il_file_unit,fmt=*,iostat=id_error) &
+              il_pos,cl_cfname,cl_cfunit
+
+           if(id_error.eq.0) then
+             if(il_pos.le.il_max_entry_id) then
+               cfldlab(il_pos)=trim(cl_cfname)
+               cfunitslab(il_pos)=trim(cl_cfunit)
+             else
+               write(nulprt,*) &
+                   'psmile_io_init_comp:cf_name_table.txt:' &
+                  ,'Record ',il_i,': numlab =',il_pos,' out of range!'
+               call flush(nulprt)
+               call MPI_Abort(mpi_comm,0,mpi_error)
+             endif
+           else
+             write(nulprt,*) &
+                 'psmile_io_init_comp:cf_name_table.txt:' &
+                ,'Reading record ',il_i,' failed!'
+             call flush(nulprt)
+             call MPI_Abort(mpi_comm,0,mpi_error)
+           endif
+           
+         enddo
+
+       endif
+
+
+
+!RV
+       deallocate(il_cpl_ranks)
+#ifdef __VERBOSE
+       write(nulprt,*) 'End - - psmile_io_init_comp'
+#endif
+
+       return
+       end
+
+       subroutine psmile_def_domains(id_error)
+!--------------------------------------------------------------------------
+!
+!	Routine defines the IO domain partitioning
+!       Called at the end of prism_enddef.
+!
+       use mod_kinds_model      
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+       use mod_psmile_io_interfaces, only:indexi
+       implicit none
+       
+#include <mpif.h>
+
+       integer(kind=ip_intwp_p),intent(out)::id_error
+       
+       integer(kind=ip_intwp_p)::il_port,il_i,il_j,il_ldx
+       integer(kind=ip_intwp_p),allocatable::il_gextents(:,:,:)
+       integer(kind=ip_intwp_p),allocatable::il_offsets(:,:,:)
+       integer(kind=ip_intwp_p),allocatable::il_extentsx(:)
+       integer(kind=ip_intwp_p),allocatable::il_extentsy(:)
+       integer(kind=ip_intwp_p),allocatable::il_offsetx(:)
+       integer(kind=ip_intwp_p),allocatable::il_offsety(:)
+       logical,allocatable::ll_mask(:,:)
+       integer(kind=ip_intwp_p),allocatable::il_pelist(:)
+       integer(kind=ip_intwp_p)::il_ngx,il_ngy
+       integer(kind=ip_intwp_p)::il_recvcount=1,il_sum
+
+!Assumption: Processes beloging to the same model have the same 
+!             strategy per port. Each process involved  in the
+!              coupling has the same number of ports
+
+#ifdef __VERBOSE
+       write(nulprt,*)'Start - - psmile_def_domains'
+#endif
+
+       id_error=CLIM_ok
+
+!Global arrays 
+       allocate(domain(1:nports))
+       allocate(xdom(1:nports))
+       allocate(ydom(1:nports))
+       allocate(lg_is_odd_distribution(1:nports))
+
+!Local arrays
+!il_gextents(:,1,:) carries extents in x, il_gextents(:,2,:) extents in y
+       allocate(il_gextents(0:ig_mpp_io_comm_size-1,1:2,1:nports))
+       allocate(il_offsets(1:ig_mpp_io_comm_size,1:2,1:nports))
+       allocate(il_pelist(0:ig_mpp_io_comm_size-1))
+       allocate(il_extentsx(0:ig_mpp_io_comm_size-1))
+       allocate(il_extentsy(0:ig_mpp_io_comm_size-1))
+       allocate(il_offsetx(0:ig_mpp_io_comm_size-1))
+       allocate(il_offsety(0:ig_mpp_io_comm_size-1))
+       allocate(ll_mask(0:ig_mpp_io_comm_size-1,0:ig_mpp_io_comm_size-1))
+       
+       if(ig_color/ig_mynummod.ne.1000) then
+         WRITE(nulprt,*)'psmile_def_domains: Called by proc which is not' &
+                       ,' involved with coupling!'
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+
+       do il_port=1,nports
+#ifdef __VERBOSE
+        WRITE(nulprt,*)'ig_def_state ',ig_def_state(il_port)  
+#endif
+       IF (ig_def_state(il_port) .eq. ip_ignout .or. &
+            ig_def_state(il_port) .eq. ip_expout .or. &
+            ig_def_state(il_port) .eq. ip_output .or. &
+            ig_def_state(il_port) .eq. ip_input ) THEN
+#ifdef __VERBOSE
+       WRITE(nulprt,*)'psmile_def_domains: port: ',il_port
+       call flush(nulprt)
+#endif
+
+         if( mydist(CLIM_Strategy,il_port) .eq. CLIM_Serial) then
+
+#ifdef __VERBOSE
+           WRITE(nulprt,*)'psmile_def_domains: port: ',il_port,' CLIM_Serial'
+#endif
+
+           if(ig_mpp_io_comm_size.eq.1)then
+#ifdef __VERBOSE
+              WRITE(nulprt,*)'psmile_def_domains: port: ',il_port &
+                         ,'(/1,mydist( CLIM_Segments+2,il_port),1,1/)' &
+                         ,1,mydist(CLIM_Segments+2,il_port),1,1
+!             call flush(nulprt)
+#endif
+             ig_layout(1:2)=1
+             call mpp_define_domains((/1,mydist( CLIM_Segments+2,il_port),1,1/)&
+                                    , ig_layout,domain(il_port))
+             call mpp_get_domain_components( domain(il_port), xdom(il_port),&
+                                             ydom(il_port) )
+           else
+	     write(nulprt, * ) 'psmile_def_domains: no. of procs for I/O ',&
+                             '> 1 and CLIM_Serial does not make sense! '
+             call MPI_ABORT(mpi_comm,0,mpi_err)
+
+           endif
+            
+         else if( mydist(CLIM_Strategy,il_port) .eq. CLIM_Apple) then
+
+#ifdef __VERBOSE
+           WRITE(nulprt,*)'psmile_def_domains: port: ',il_port,' CLIM_Apple',mydist(:,il_port)
+#endif
+
+!Assuming 1D decomposition. At the this point this is the only information
+!which I have considering CLIM_Apple!
+
+           ig_layout(1)=ig_mpp_io_comm_size
+           ig_layout(2)=1
+
+!Build a list of the local extents which exists on the procs involved with
+!coupling
+           call MPI_Allgather(mydist(CLIM_Length+1,il_port),1,MPI_INTEGER,&
+                             il_gextents(0,1,il_port),il_recvcount,MPI_INTEGER,&
+                              ig_mpp_io_comm,id_error)
+           call MPI_Allgather(mydist(CLIM_Offset+1,il_port),1,MPI_INTEGER,&
+                              il_offsets(1,1,il_port),il_recvcount,MPI_INTEGER,&
+                              ig_mpp_io_comm,id_error)
+
+!Sort the extents and the PE-list according to the offsets
+
+           call indexi(ig_mpp_io_comm_size &
+                      ,il_offsets(1:ig_mpp_io_comm_size,1,il_port),il_pelist)
+
+           il_pelist(:)=il_pelist(:)-1
+           il_extentsx(0:ig_mpp_io_comm_size-1)=&
+                     il_gextents(il_pelist(:),1,il_port)
+
+!The max global index for the current 1D decomposition.
+           il_sum=sum(il_extentsx(0:ig_mpp_io_comm_size-1))
+
+#ifdef __VERBOSE
+           WRITE(nulprt,*)'psmile_def_domains: port: ',il_port &
+                         ,'(/1,il_sum,1,1/),pelist',1,il_sum,1,1,il_pelist &
+                         ,'extents',il_extentsx
+#endif
+!Define a pseudo 2D domain
+           il_extentsy(0)=1
+           call mpp_define_domains((/1,il_sum,1,1/),(/ig_mpp_io_comm_size,1/),&
+                                  domain(il_port),&
+                                  pelist=il_pelist,&
+                                  xextent=il_extentsx,&
+                                  yextent=il_extentsy(0:0))
+           call mpp_get_domain_components( domain(il_port), xdom(il_port),&
+                                           ydom(il_port) )
+
+         else if( mydist(CLIM_Strategy,il_port) .eq. CLIM_Box) then
+
+#ifdef __VERBOSE
+           WRITE(nulprt,*)'psmile_def_domains: port: ',il_port,' CLIM_Box'
+!           WRITE(nulprt,*)'psmile_def_domains: port: ',il_port,' CLIM_Box', &
+!           mydist(:,il_port),'::',myport(:,il_port)
+#endif
+!Build a list of the local extents which exists on the procs involved with
+!coupling
+!Block sizes in x
+           call MPI_Allgather(mydist(CLIM_SizeX+1,il_port),1,MPI_INTEGER,&
+                             il_gextents(0,1,il_port),il_recvcount,MPI_INTEGER,&
+                              ig_mpp_io_comm,id_error)
+!Block sizes in y
+           call MPI_Allgather(mydist(CLIM_Segments,il_port),1,MPI_INTEGER,&
+                             il_gextents(0,2,il_port),il_recvcount,MPI_INTEGER,&
+                              ig_mpp_io_comm,id_error)
+!Offsets of the blocks
+           call MPI_Allgather(mydist(CLIM_Offset+1,il_port),1,MPI_INTEGER,&
+                              il_offsets(1,1,il_port),il_recvcount,MPI_INTEGER,&
+                              ig_mpp_io_comm,id_error)
+
+           call indexi(ig_mpp_io_comm_size &
+                      ,il_offsets(1:ig_mpp_io_comm_size,1,il_port),&
+                           il_pelist)
+           il_pelist(:)=il_pelist(:)-1
+
+           il_extentsx(0:ig_mpp_io_comm_size-1)=&
+                       il_gextents(il_pelist(:),1,il_port)
+           il_extentsy(0:ig_mpp_io_comm_size-1)=&
+                       il_gextents(il_pelist(:),2,il_port)
+#ifdef __VERBOSE
+!           write(nulprt,*)'psmile_def_domains:il_extentsx',il_extentsx
+!           write(nulprt,*)'psmile_def_domains:il_extentsy',il_extentsy
+#endif
+! At this point I have to think about the domain decomposition
+! 1st assumption : The leading dimension is a global parameter for
+!                  the model. So, I don't do further checks on that.
+
+           il_ldx=mydist(CLIM_Segments+3,il_port)-mydist(CLIM_Offset+1,il_port)
+#ifdef __VERBOSE
+!           write(nulprt,*)'psmile_def_domains: LDX = ',il_ldx
+#endif
+
+
+!Count the number of offsets which are less than LDX to get the partitioning
+!in x-direction
+           ig_layout(1)=&
+           count(mask=il_offsets(:,1,il_port).lt.il_ldx)
+
+           if(ig_layout(1).gt.0) then
+             ig_layout(2)=ig_mpp_io_comm_size/ig_layout(1)
+             if(ig_layout(1)*ig_layout(2).ne.ig_mpp_io_comm_size) then
+               lg_is_odd_distribution(il_port)=.true.
+             else
+!check within a column y  for different extents of y
+               lg_is_odd_distribution(il_port)=.false.
+               do il_j=0,ig_layout(2)-1
+                 do il_i=1,ig_layout(1)-1
+                   lg_is_odd_distribution(il_port)= &
+                   il_extentsy(ig_layout(1)*il_j).ne.&
+                     il_extentsy(il_i+ig_layout(1)*il_j)
+#ifdef __VERBOSE
+!                 write(nulprt,*)'i j extentsy ',il_i,il_j, &
+!                 il_extentsy(ig_layout(1)*il_j), &
+!                 il_extentsy(il_i+ig_layout(1)*il_j)
+#endif
+                 enddo
+               enddo
+
+!check within a column x  for different extents of x
+               do il_i=0,ig_layout(2)-1
+                 do il_j=1,ig_layout(1)-1
+                   lg_is_odd_distribution(il_port)= &
+                   il_extentsx(il_i).ne.il_extentsx(il_i+ig_layout(1)*il_j)
+#ifdef __VERBOSE
+!                 write(nulprt,*)'i j extentsy ',il_i,il_j, &
+!                 il_extentsx(il_i), &
+!                 il_extentsx(il_i+ig_layout(1)*il_j)
+#endif
+                 enddo
+               enddo
+
+             endif
+
+!Okay, fine! There are global divisors of the x- and y-axis!
+             if(.not.lg_is_odd_distribution(il_port)) then
+
+
+               il_ngx= il_ldx
+               il_ngy=il_offsets(il_pelist(ig_mpp_io_comm_size-1)+1,1,il_port)&
+                    /il_ngx  + il_extentsy(ig_mpp_io_comm_size-1)
+
+#ifdef __VERBOSE
+               WRITE(nulprt,*)'psmile_def_domains: port: ',il_port &
+                             ,'(/1,il_ngx,1,il_ngy/),pelist' &
+                             ,1,il_ngx,1,il_ngy,il_pelist
+#endif
+
+               call mpp_define_domains((/1,il_ngx,1,il_ngy/) &
+                                      ,ig_layout,domain(il_port) &
+                   ,xextent=il_extentsx(0:ig_mpp_io_comm_size-1:ig_layout(2)) & 
+                   ,yextent=il_extentsy(0:ig_mpp_io_comm_size-1:ig_layout(1)) &
+			              ,pelist=il_pelist)
+               call mpp_get_domain_components( domain(il_port), xdom(il_port),&
+                                           ydom(il_port) )
+
+             else
+
+!Okay, at this point it seems that have we have a block-structured
+!distribution. Need to calculate the offsets of the blocks in x- and y-
+!direction. These offsets migth be provided by prism_set_offset.
+               ll_mask(:,:)=.false.
+               do il_i=0,ig_mpp_io_comm_size-1
+               ll_mask(il_pelist(il_i),il_pelist(il_i))=.true.
+               enddo
+               il_ngx=il_ldx
+               il_offsetx(:)=il_offsets(il_pelist(0:ig_mpp_io_comm_size-1)+1,1,il_port) &
+                            -il_ngx* &
+                            (il_offsets(il_pelist(0:ig_mpp_io_comm_size-1)+1,1,il_port) &
+			    /il_ngx)
+               il_offsety(:)=il_offsets(il_pelist(0:ig_mpp_io_comm_size-1)+1,1,il_port) &
+                            /il_ngx
+               il_ngy=il_offsety(ig_mpp_io_comm_size-1) &
+                     +il_extentsy(ig_mpp_io_comm_size-1)
+               ig_layout(1)=ig_mpp_io_comm_size
+               ig_layout(2)=ig_mpp_io_comm_size
+
+#ifdef __VERBOSE
+               WRITE(nulprt,*)'psmile_def_domains: port: ',il_port &
+                             ,' :fall back: (/1,il_ngx,1,il_ngy/),pelist' &
+                             ,1,il_ngx,1,il_ngy,il_pelist,il_offsetx(:) &
+                             ,il_offsety(:)
+#endif
+
+               call mpp_define_domains((/1,il_ngx,1,il_ngy/) &
+                                      ,ig_layout,domain(il_port) &
+                                      ,xextent=il_extentsx &
+                                      ,yextent=il_extentsy & 
+                                      ,pelist=il_pelist,maskmap=ll_mask &
+                                      ,offsetx=il_offsetx,offsety=il_offsety)
+               call mpp_get_domain_components( domain(il_port), xdom(il_port),&
+                                           ydom(il_port) )
+             endif
+
+           else
+
+	     write(nulprt, * ) 'psmile_def_domains: ig_layout(1) =0! '
+             call MPI_ABORT(mpi_comm,0,mpi_err)
+           endif
+
+         else if( mydist(CLIM_Strategy,il_port) .eq. CLIM_Orange) then
+
+	   write(nulprt, * ) 'psmile_def_domains: Strategy CLIM_orange',&
+                             'not yet implemented for I/O!'
+           call MPI_ABORT(mpi_comm,0,mpi_err)
+
+         endif
+         endif
+       enddo
+
+!Cleanup
+       deallocate(il_pelist)
+       deallocate(il_extentsx)
+       deallocate(il_extentsy)
+       deallocate(il_gextents)
+       deallocate(il_offsets)
+       deallocate(il_offsetx)
+       deallocate(il_offsety)
+       deallocate(ll_mask)
+
+#ifdef __VERBOSE
+       WRITE(nulprt,*)'End - - psmile_def_domains:'
+       call flush(nulprt)
+#endif
+
+       
+       end subroutine psmile_def_domains
+
+       subroutine psmile_def_files(id_error)
+!--------------------------------------------------------------------------
+!
+!      This subroutine open files acccording to the kewords 
+!      OUTPUT: write by model issueing prism_put
+!      INPUT:  read by  issueing prism_get
+!      EXPOUT: write by model issueing  prism_put and prims_get after receive.
+!	       Usage for debugging data exchange model->Oasis->model
+!      IGNOUT: write by model issueing  prism_put and prims_get after receive.
+!	       Usage for debugging data exchange model->model
+!
+!       Called at the end of prism_enddef.
+!
+       use mod_kinds_model	
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+       use mod_psmile_io_interfaces,only:combine_with_date
+       use mod_psmile_date_and_time
+
+       implicit none
+
+#include <mpif.h>
+
+       integer(kind=ip_intwp_p),intent(out)::id_error
+!Local variables
+       integer(kind=ip_intwp_p)::il_i,il_port,il_unit
+!Test       integer(kind=ip_intwp_p),allocatable::il_units(:)
+       logical:: ll_opened,ll_exist
+
+#ifdef __VERBOSE
+       write(nulprt,*)'Start - - psmile_def_files'
+       call flush(nulprt)
+#endif
+
+       if(ig_color/ig_mynummod.ne.1000) then
+         WRITE(nulprt,*)'psmile_def_files: Called by proc which is not' &
+                       ,' involved with coupling!'
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+
+       if((.not.allocated(domain))) then
+         WRITE(nulprt,*)'psmile_def_files:' &
+                       ,' Not called after psmile_def_domains!' 
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+        
+
+       id_error=CLIM_Ok
+
+!Find unused units.
+!Problem is here that mpi codes usually are scattering/collecting from/on one PE
+! which read/write. The rank of that PE is not known  to PSMILE.
+!Algorithm: Let each PE involved with coupling do a search beginning from 
+!PSMILE_MAX_UNIT. Check if the result is the same on each couple task.
+!Currently I don't know if the check is absolutely necessary.
+!Moreover, I assume that MPI is doing private I/O for each task, means
+!each opened file is handled individually per task by the OS .
+!I made my experience with UNICOS where file handling where global per default
+!running MPI in autotasking mode. In that case the user had to specify a
+!certain FFIO flag to get the normal behaviour.
+
+!Test  allocate(il_units(1:ig_mpp_io_comm_size))
+       allocate(ig_units(1:nports))
+!RV:22.01.2003
+       ig_units=-1
+
+       il_unit=PSMILE_MAX_UNIT
+       do il_port=1,nports
+          IF (ig_def_state(il_port) .eq. ip_ignout .or. &
+            ig_def_state(il_port) .eq. ip_expout .or. &
+            ig_def_state(il_port) .eq. ip_output .or. &
+            ig_def_state(il_port) .eq. ip_input ) THEN
+         do
+           inquire(unit=il_unit,exist=ll_exist,opened=ll_opened)
+           if( ll_exist .and. (.not.ll_opened)) exit
+           il_unit=il_unit-1
+           if(il_unit.eq.PSMILE_MAX_RESERVED_UNIT) &
+              il_unit=PSMILE_MIN_RESERVED_UNIT-1
+           if(il_unit.eq.7) then
+             write(nulprt,*)'psmile_def_files: Could not find unit!'
+             call MPI_ABORT(mpi_comm,0,mpi_err)
+           endif
+         enddo
+         ig_units(il_port)=il_unit
+
+#ifdef __VERBOSE
+         write(nulprt,*)'psmile_def_files: Found FORTRAN I/O unit ', il_unit
+         call flush(nulprt)
+#endif
+
+         il_unit=il_unit-1
+         endif
+       enddo
+
+!Opening files!
+!I am opening the files such that read / write is performed on one file.
+!One can easily change that to distributed i/o changing the fileset attribute.
+        
+       allocate(ig_action(1:nports))
+       allocate(ig_form(1:nports))
+       allocate(ig_threading(1:nports))
+       allocate(ig_fileset(1:nports))
+       allocate(cg_my_input_file(1:nports))
+       allocate(cg_output_file(1:nports))
+
+!       call_mpp_sync()
+       do il_port=1,nports
+         if(ig_def_state(il_port).eq.ip_input) then
+
+           ig_action(il_port)=MPP_RDONLY
+	   ig_form(il_port)=MPP_NETCDF
+	   ig_threading(il_port)=MPP_MULTI
+	   ig_fileset(il_port)=MPP_SINGLE
+
+!I create here the name of the input file according to the convention
+!cports(il_port)_in.<year>-<month>-<day>T<hh>:<mm>:ss.nc
+!Arnaud, if you like you prefer approach of reading the name from the namcouple
+!initialize cg_my_input_file accordingly and comment out the call of
+!combine_with_date.
+
+!           call combine_with_date(cports(il_port),'in',il_my_initial_date &
+!                                 ,cg_my_input_file(il_port))
+
+           call mpp_open( ig_units(il_port),trim(cg_def_inpfile(il_port)) &
+                        , action=ig_action(il_port) &
+                        , form=ig_form(il_port) &
+                        , threading=ig_threading(il_port) &
+                        , fileset=ig_fileset(il_port))
+           
+         elseif(ig_def_state(il_port).eq.ip_output) then
+
+           ig_action(il_port)=MPP_OVERWR
+	   ig_form(il_port)=MPP_NETCDF
+	   ig_threading(il_port)=MPP_SINGLE
+
+           call combine_with_date(cports(il_port),'out',ig_inidate &
+                                 ,cg_output_file(il_port))
+
+           call mpp_open( ig_units(il_port), trim(cg_output_file(il_port)) &
+                        , action=ig_action(il_port) &
+                        , form=ig_form(il_port) &
+                        , threading=ig_threading(il_port))
+	    
+
+         elseif(ig_def_state(il_port).eq.ip_expout) then
+
+           ig_action(il_port)=MPP_OVERWR
+	   ig_form(il_port)=MPP_NETCDF
+	   ig_threading(il_port)=MPP_SINGLE
+
+           call combine_with_date(cports(il_port),'out',ig_inidate &
+                                 ,cg_output_file(il_port))
+
+           call mpp_open( ig_units(il_port),trim(cg_output_file(il_port)) &
+                        , action=ig_action(il_port) &
+                        , form=ig_form(il_port) &
+                        , threading=ig_threading(il_port))
+
+         elseif(ig_def_state(il_port).eq.ip_ignout) then
+
+           ig_action(il_port)=MPP_OVERWR
+	   ig_form(il_port)=MPP_NETCDF
+	   ig_threading(il_port)=MPP_SINGLE
+
+           call combine_with_date(cg_ignout_field(il_port),'out',ig_inidate &
+                                 ,cg_output_file(il_port))
+
+           call mpp_open( ig_units(il_port), trim(cg_output_file(il_port)) &
+                        , action=ig_action(il_port) &
+                        , form=ig_form(il_port) &
+                        , threading=ig_threading(il_port))
+         endif
+       enddo
+
+       
+#ifdef __VERBOSE
+       write(nulprt,*)'End - - psmile_def_files'
+       call flush(nulprt)
+#endif
+       end subroutine psmile_def_files
+
+       subroutine psmile_def_metadata(id_error)
+!--------------------------------------------------------------------------
+!
+!This routine defines the metadata headers of netcdf files case or writing.
+!In case or reading it defines the  index  to lookup a certain variable in
+!a netcdf file
+!       Called at the end of prism_enddef.
+       use mod_kinds_model
+       use mod_psmile_io_interfaces,only:combine_with_date
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+       implicit none
+
+#include <mpif.h>
+
+       integer(kind=ip_intwp_p),intent(out)::id_error
+!Local
+       character(len=64)::cl_varname
+       integer(kind=ip_intwp_p)::il_port,il_i
+       integer(kind=ip_intwp_p)::il_xbegin,il_xend,il_ybegin,il_yend
+       integer(kind=ip_intwp_p)::il_ndim,il_nvar,il_natt,il_ntime
+       integer(kind=ip_intwp_p)::il_crn,il_ii,il_jj
+       
+       type(fieldtype),allocatable::il_vars(:)
+!
+!      Dimensions of the lons and lats contained in the OASIS 3 grid file
+       integer(kind=ip_intwp_p)::lens_lat(4),lens_lon(4)
+       REAL(kind=ip_realwp_p), ALLOCATABLE :: lon(:,:),lat(:,:)
+       REAL(kind=ip_realwp_p), ALLOCATABLE :: loncrn(:,:,:),latcrn(:,:,:)
+       LOGICAL                 ::   lg_exist
+       CHARACTER(len=8):: cg_clim_cgrdnamnc, clstrg
+       INTEGER(kind=ip_intwp_p):: nc_grdid, il_varid, il_x, il_y
+       REAL(kind=ip_realwp_p), ALLOCATABLE :: rl_lons(:,:), rl_lats(:,:)
+       REAL(kind=ip_realwp_p), ALLOCATABLE :: rl_lonscrn(:,:,:), rl_latscrn(:,:,:)
+       REAL(kind=ip_realwp_p):: difflon
+       REAL(kind=ip_realwp_p):: threesixty
+       LOGICAL                 ::   llylat,llxlon, ll_notfound
+
+#ifdef __VERBOSE
+       write(nulprt,*)'Start -- psmile_def_metada'
+       call flush(nulprt)
+#endif
+
+       if(ig_color/ig_mynummod.ne.1000) then
+         WRITE(nulprt,*)'psmile_def_metdata: Called by proc which is not' &
+                       ,' involved with coupling!'
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+
+       if((.not.allocated(ig_units)).and.(.not.allocated(domain))) then
+         WRITE(nulprt,*)'psmile_def_metdata:' &
+                       ,' Not called after psmile_def_domains' &
+                       ,' and psmile_def_files!'
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+        
+
+       id_error=CLIM_Ok
+       threesixty=360.0
+
+       allocate(ig_var_index(nports))
+       allocate(ig_vars(1:nports))
+       allocate(ig_ntimes(1:nports))
+
+!RV:22.01.2003
+#ifdef __READ_BY_LOOKUP
+       allocate(dg_times(1:nports))
+!AC:31/01
+       DO il_i = 1,nports
+          nullify(dg_times(il_i)%rl_times)
+       ENDDO
+#endif
+
+       allocate(x_axis(1:nports))
+       allocate(y_axis(1:nports))
+       allocate(c_axis(1:nports))
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_def_metada: Number of corners: ',ig_noc
+       call flush(nulprt)
+#endif
+       allocate(nbr_corners(1:nports))
+       nbr_corners=ig_noc
+!Was not allocated. Oasis sends 2D arrays. In case of bundles or 3d arrays
+!we have to declare z_axis + plus one for bundles.
+!Left here as a reminder!
+!       allocate(z_axis(1:nports))
+       allocate(t_axis(1:nports))
+       allocate(field(1:nports))
+       allocate(lonij(1:nports))
+       allocate(latij(1:nports))
+       allocate(crnlonij(1:nports))
+       allocate(crnlatij(1:nports))
+
+!The following files are allocated here since no informations
+!are given in Oasis regarding to long names and units. I am filling them with
+!dummy informations. I put the data structure into mod_psmile_io.
+       allocate(cports_lgname(1:nports))
+       allocate(cports_units(1:nports))
+       cports_lgname='BLANK'
+       cports_units='1'
+       
+
+       DO il_port=1,nports
+	  IF(ig_def_state(il_port).EQ.ip_input) THEN
+
+!Get information with regard to no. of dimensions, variables, attributes
+!and time stamps.
+	    call mpp_get_info(ig_units(il_port)&
+			     ,il_ndim,il_nvar,il_natt,il_ntime)
+	    
+            ig_ntimes(il_port)=il_ntime
+
+            allocate(il_vars(1:il_nvar))
+!RV,16.12.2002:Get the all ids of the fields within the file.
+            call mpp_get_fields (ig_units(il_port),il_vars(:))
+
+!Loop over variables and find the index of cports(il_port).
+            ig_var_index(il_port)=-1
+	    do il_i=1,il_nvar
+
+	      call mpp_get_atts(il_vars(il_i),name=cl_varname)
+	      if(trim(cl_varname).eq.trim(cports(il_port)) ) then 
+		ig_var_index(il_port)=il_i
+		ig_vars(il_port)=il_vars(il_i)
+              endif
+
+	    enddo
+
+!Check: Did I find the variable? If not, the user has given the wrong
+!       input file.
+            if(ig_var_index(il_port).lt.0) then
+
+              write(nulprt, * ) &
+                  'psmile_def_metadata: Variable name given in namcouple '&
+                  ,cports(il_port) &
+                  ,'could not be found in file ',cg_my_input_file(il_port) &
+                  ,' port number: ',il_port
+              call MPI_ABORT(mpi_comm,0,mpi_err)
+
+            endif
+
+	    deallocate(il_vars)
+
+	  elseif((ig_def_state(il_port).eq.ip_output).or. &
+		 (ig_def_state(il_port).eq.ip_expout).or. &
+		 (ig_def_state(il_port).eq.ip_ignout))then
+
+!Define the global axis X and Y.
+!I have no informations on the units of the axis. I assume that
+!the axis are indices in order to perform a mapping like lat(i,j).
+	    call mpp_get_global_domain(domain(il_port) &
+                                      ,xbegin=il_xbegin,xend=il_xend &
+                                      ,ybegin=il_ybegin,yend=il_yend)
+            call mpp_write_meta(ig_units(il_port) &
+                               ,'Conventions' &
+                               ,cval='CF-1.0')
+#ifdef __VERBOSE
+            write(nulprt,*)'psmile_def_metadata: x-axis ',il_xbegin,il_xend
+#endif
+
+            call mpp_write_meta(ig_units(il_port),x_axis(il_port) &
+                               ,'X','1','global index space for x' &
+                               ,domain=xdom(il_port) &
+                               ,data=(/(il_i-1.,il_i=il_xbegin,il_xend)/) )
+
+#ifdef __VERBOSE
+            write(nulprt,*)'psmile_def_metadata: y-axis ',il_ybegin,il_yend
+            call flush(nulprt)
+#endif
+
+            call mpp_write_meta(ig_units(il_port),y_axis(il_port) &
+                               ,'Y','1','global index space for y' &
+                               ,domain=ydom(il_port) &
+                               ,data=(/(il_i-1.,il_i=il_ybegin,il_yend)/) )
+#ifdef __VERBOSE
+            write(nulprt,*)'psmile_def_metadata: c-axis '
+#endif
+            call mpp_write_meta(ig_units(il_port),c_axis(il_port) &
+                               ,'C','1','global index space for c' &
+                               ,data=(/(il_i-1.,il_i=1,nbr_corners(il_port))/) )
+
+
+!Define the unlimited time axis
+            call combine_with_date('second','since',ig_inidate &
+                                 ,cl_varname)
+
+            call mpp_write_meta( ig_units(il_port), t_axis(il_port) &
+                               , 'time', trim(cl_varname), 'Time' )
+!Define the real coordinates , here lattitudes and longitudes.
+! I have no information with regard to latitude and longitude
+!RV:17.04.2003 Wright this information anyway to pass the CF check.
+            call mpp_write_meta( ig_units(il_port), latij(il_port) &
+                               , (/x_axis(il_port),y_axis(il_port)/) &
+                               , 'lat', 'degrees_north' &
+                               , 'latitude')
+            call mpp_write_meta( ig_units(il_port), lonij(il_port) &
+                               , (/x_axis(il_port),y_axis(il_port)/) &
+                               , 'lon', 'degrees_east' &
+                               , 'longitude')
+!rv,sgi Number of corners has to be the leading dimension according the
+!rv,sgi CF convention
+            call mpp_write_meta( ig_units(il_port), crnlatij(il_port) &
+                      , (/c_axis(il_port),x_axis(il_port),y_axis(il_port)/) &
+                      , 'bounds_lat', 'degrees_north' &
+                      , 'corner latitudes')
+            call mpp_write_meta( ig_units(il_port), crnlonij(il_port) &
+                      , (/c_axis(il_port),x_axis(il_port),y_axis(il_port)/) &
+                      , 'bounds_lon', 'degrees_east' &
+                      , 'corner longitudes')
+!Define that variable cports(il_port) of unit cports_units(il_port) and
+!longname cports_lgname(il_port) will be written as field field(il_port)
+!according to the three axis x_axis(il_port),y_axis(il_port) and
+!t_axis(il_port). The precision is double (pack=1).
+!RV
+! Initialize cports_lgname and cports_units  according to the CF name table 
+! exploiting the field label.
+!
+            IF(allocated(cfldlab)) then
+              IF(ig_def_numlab(il_port).gt.0.and. &
+                ig_def_numlab(il_port).le.PSMILE_MAX_CF_TABLE_ENTRIES) then
+                 cports_lgname(il_port)=cfldlab(ig_def_numlab(il_port))
+                 cports_units(il_port)=cfunitslab(ig_def_numlab(il_port))
+              ENDIF
+            ENDIF
+!RV
+            IF (ig_def_state(il_port).EQ.ip_ignout) THEN
+               call mpp_write_meta( ig_units(il_port), field(il_port) &
+                    , (/x_axis(il_port),y_axis(il_port) &
+                    ,t_axis(il_port)/) &
+                    ,trim(cg_ignout_field(il_port)) &
+                    ,trim(cports_units(il_port)) &
+                    , trim(cports_lgname(il_port)), pack=1 )
+#ifdef __DEBUG
+              write(nulprt,*)'psmile_def_metadata 1:',ig_def_numlab(il_port) &
+                            ,' ',trim(cg_ignout_field(il_port)) &
+                            ,' ',trim(cports_lgname(il_port)) &
+                            ,' ',trim(cports_units(il_port))
+              call flush(nulprt)
+#endif
+            ELSE
+               call mpp_write_meta( ig_units(il_port), field(il_port) &
+                    , (/x_axis(il_port),y_axis(il_port) &
+                    ,t_axis(il_port)/) &
+                    ,trim(cports(il_port)) &
+                    ,trim(cports_units(il_port)) &
+                    , trim(cports_lgname(il_port)), pack=1 )
+#ifdef __DEBUG
+              write(nulprt,*)'psmile_def_metadata 2:',ig_def_numlab(il_port) &
+                            ,' ', trim(cports(il_port)) &
+                            ,' ',trim(cports_lgname(il_port)) &
+                            ,' ',trim(cports_units(il_port))
+              call flush(nulprt)
+#endif
+             ENDIF
+
+!
+!            Define an additional attribute bounds for lon and lats.
+!
+             call mpp_write_meta(ig_units(il_port) &
+                                ,mpp_get_id(latij(il_port)) &
+                                , 'bounds',cval='bounds_lat')
+             call mpp_write_meta(ig_units(il_port) &
+                                ,mpp_get_id(lonij(il_port)) &
+                                , 'bounds',cval='bounds_lon')
+!Define an additional attribute that field(il_port) lives on the coordinates
+!lon and lat. This is a CF requirement!
+
+             call mpp_write_meta(ig_units(il_port) &
+                                ,mpp_get_id(field(il_port)) &
+                                , 'coordinates',cval='lon lat')
+
+!Flush the  metadata information to the file connected to unit 
+!ig_units(il_port).
+
+             call mpp_write(ig_units(il_port), x_axis(il_port) )
+             call mpp_write(ig_units(il_port), y_axis(il_port) )
+!
+!rv          Metadata should be flushed from the struct c_axis
+!rv          into the NetCDF file
+!
+             call mpp_write(ig_units(il_port), c_axis(il_port) )
+!
+             IF (mpp_pe() .EQ. mpp_root_pe()) THEN
+                 WRITE(nulprt,*)'mod_psmile_io - - check grids.nc file:'     
+                 cg_clim_cgrdnamnc=cg_clim_cgrdnam//'.nc'                  
+                 INQUIRE(FILE = cg_clim_cgrdnamnc, EXIST = lg_exist)       
+                 IF (.NOT. lg_exist) THEN                                  
+                     WRITE(nulprt,*) '     - no grids.nc file found'
+                     WRITE(nulprt,*) 'lats and lons will not be written to output files' 
+                     CALL flush(nulprt)                                    
+                 ELSE                                                      
+                     WRITE(nulprt,*)'mod_psmile_io - - grids.nc file found'
+                     ! Read the lats and the lons
+                     CALL mpp_open(nc_grdid, 'grids', &
+                        action=MPP_RDONLY, &
+                        form=MPP_NETCDF, &
+                        threading=MPP_SINGLE)
+                     CALL mpp_get_info(nc_grdid, il_ndim, il_nvar, &
+                        il_natt, il_ntime )
+                     ALLOCATE(il_vars(1:il_nvar))
+                     CALL mpp_get_fields (nc_grdid,il_vars(:))
+                     !
+                     ! Longitudes
+                     !
+                     clstrg = cga_clim_locator(il_port)//cg_clim_lonsuf
+                     il_i = 0
+                     ll_notfound = .TRUE.
+                     DO WHILE (ll_notfound)
+                       il_i = il_i + 1
+                       IF (il_i .GT. il_nvar) THEN
+                           WRITE(nulprt,*)'psmile_def_metdata: Pb in file grids.nc: No longitudes' &
+                              ,'for grid', cga_clim_locator(il_port)
+                           WRITE(nulprt,*)'Calling MPI_ABORT '
+                           CALL flush(nulprt)
+                           CALL MPI_ABORT(mpi_comm,0,mpi_err)
+                       ENDIF
+                       CALL mpp_get_atts(il_vars(il_i),name=cl_varname,siz=lens_lon)
+!
+!RV,sgi                       ALLOCATE(lon(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1))
+!
+                       IF(TRIM(cl_varname).EQ.TRIM(clstrg) ) THEN
+                           ll_notfound = .FALSE.
+#ifdef __VERBOSE
+                           write(nulprt,*)'psmile_def_metadata: cl_varname= ' &
+                           ,trim(cl_varname)
+                           call flush(nulprt)
+#endif
+                           IF(.NOT.ALLOCATED(lon)) &
+                           ALLOCATE(lon(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1))
+                           ALLOCATE(rl_lons(lens_lon(1),lens_lon(2)))
+
+                           !NOTE: I am using tindex = 1 in order to circumvent a
+                           !peculiarity of mpp_io: grids.nc contains the lons/lats
+                           !declared as lon(i,j)/lat(i,j). mpp_io interprets i and j as
+                           !axes. However, the axis i and j have no associated data.
+                           !Therefore, i and j are NOT taken as spatial axes but
+                           !as something related to a time stamp. Until that "feature"
+                           !is corrected  use the call below.
+                           !
+                           CALL mpp_read(nc_grdid,il_vars(il_i),rl_lons,tindex=1)
+                           !
+!rv,sgi<
+                           !If the user has specified INVERT/REVERSE and 
+                           !$CORLAT=NORSUD and/or $CORLON=ESTWST in the 
+                           !preprocessing section of the field we INVERT the 
+                           !ordering of longitudes such that data and grid are
+                           !are matching. The assertion is that 
+                           !grid informations are initialized SUDNOR and WSTEST.
+
+                           if((ig_def_invert(il_port).gt.1).or. &
+                              (ig_def_reverse(il_port).gt.1)) then
+                             llxlon=ig_def_invert(il_port).eq.3  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.3  &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             llylat=ig_def_invert(il_port).eq.2  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.2 &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             call inv2d (rl_lons,lens_lon(1),lens_lon(2) &
+                                         ,llxlon,llylat)
+                           endif
+!rv,sgi>
+                           !Reshape the read array such that it matches the current
+                           !axes of the output file.
+                           !
+                           lon=RESHAPE(rl_lons,shape=SHAPE(lon))
+                           !
+                           !Dump it ot the output file.
+                           !
+                           CALL mpp_write(ig_units(il_port),lonij(il_port),lon)
+                           DEALLOCATE(rl_lons)
+                       ENDIF
+                     ENDDO
+                     !
+                     !Latitudes
+                     !
+                     clstrg = cga_clim_locator(il_port)//cg_clim_latsuf
+!
+                     il_i = 0
+                     ll_notfound = .TRUE.
+                     DO WHILE (ll_notfound)
+                       il_i = il_i + 1
+                       IF (il_i .GT. il_nvar) THEN
+                           WRITE(nulprt,*)'psmile_def_metdata: Pb in file grids.nc: No latitudes' &
+                              ,'for grid', cga_clim_locator(il_port)
+                           WRITE(nulprt,*)'Calling MPI_ABORT '
+                           CALL flush(nulprt)
+                           CALL MPI_ABORT(mpi_comm,0,mpi_err)
+                       ENDIF
+
+!
+                       CALL mpp_get_atts(il_vars(il_i),name=cl_varname,siz=lens_lat)
+                       IF(TRIM(cl_varname).EQ.TRIM(clstrg) ) THEN
+                           ll_notfound = .FALSE.
+#ifdef __VERBOSE
+                           write(nulprt,*)'psmile_def_metadata: cl_varname= ' &
+                           ,trim(cl_varname)
+                           call flush(nulprt)
+#endif
+                           ALLOCATE(lat(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1))
+                           ALLOCATE(rl_lats(lens_lat(1),lens_lat(2)))
+
+                           CALL mpp_read(nc_grdid,il_vars(il_i),rl_lats,tindex=1)
+!rv,sgi<
+                           if((ig_def_invert(il_port).gt.1).or. &
+                              (ig_def_reverse(il_port).gt.1)) then
+                             llxlon=ig_def_invert(il_port).eq.3  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.3  &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             llylat=ig_def_invert(il_port).eq.2  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.2 &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             call inv2d (rl_lats,lens_lat(1),lens_lat(2) &
+                                         ,llxlon,llylat)
+                           endif
+!rv,sgi>
+                           lat=reshape(rl_lats,shape=shape(lat))
+                           call mpp_write(ig_units(il_port),latij(il_port),lat)
+                           DEALLOCATE(rl_lats)
+                       ENDIF
+                     ENDDO
+                     !
+                     ! Longitude corners
+                     !
+                     clstrg = cga_clim_locator(il_port)//crn_clim_lonsuf
+
+                     ll_notfound = .TRUE.
+
+                     DO il_i=1,il_nvar
+
+                       CALL mpp_get_atts(il_vars(il_i),name=cl_varname,siz=lens_lon)
+                       IF(TRIM(cl_varname).EQ.TRIM(clstrg) ) THEN
+                           ll_notfound = .FALSE.
+#ifdef __VERBOSE
+                           write(nulprt,*) &
+                           'psmile_def_metada, lon, clstrg: ',clstrg,lens_lon 
+#endif
+                           nbr_corners(il_port)=lens_lon(3)
+                           ALLOCATE(rl_lonscrn(lens_lon(1),lens_lon(2) &
+                                              ,nbr_corners(il_port)))
+                           ALLOCATE(loncrn(nbr_corners(il_port) &
+                                          ,1:il_xend-il_xbegin+1 &
+                                          ,1:il_yend-il_ybegin+1))
+                           lens_lon(1)=il_xend-il_xbegin+1
+                           lens_lon(2)=il_yend-il_ybegin+1
+                           lens_lon(3)=nbr_corners(il_port)
+                           !
+                           CALL mpp_read(nc_grdid,il_vars(il_i),rl_lonscrn,tindex=1)
+!rv,sgi<
+                           if((ig_def_invert(il_port).gt.1).or. &
+                              (ig_def_reverse(il_port).gt.1)) then
+                             llxlon=ig_def_invert(il_port).eq.3  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.3  &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             llylat=ig_def_invert(il_port).eq.2  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.2 &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             call inv2dcrn (rl_lonscrn,lens_lon(1),lens_lon(2) &
+                                           ,nbr_corners(il_port),llxlon,llylat)
+                           endif
+!rv,sgi>
+
+                           !
+                           !Reshape the read array such that it matches the current
+                           !axes of the output file.
+                           !
+                           call transp_crn2cf(rl_lonscrn,loncrn,lens_lon)
+!rv,sgi<
+                           !
+                           ! Check for cyclic boundaries !
+                           ! For plot routines using a mesh-fill method
+                           ! the distances of the cell centers to the corners
+                           ! have to be less equal 360. degrees.
+                           !
+                            do il_crn=1,nbr_corners(il_port)
+                              do il_jj=1,il_yend-il_ybegin+1
+                              do il_ii=1,il_xend-il_xbegin+1
+                                difflon=lon(il_ii,il_jj)- &
+                                        loncrn(il_crn,il_ii,il_jj)
+                                if(difflon.gt.300.0) then
+                                  loncrn(il_crn,il_ii,il_jj)= &
+                                         loncrn(il_crn,il_ii,il_jj)+threesixty
+                                elseif(difflon.lt.-300.0) then
+                                  loncrn(il_crn,il_ii,il_jj)= &
+                                         loncrn(il_crn,il_ii,il_jj)-threesixty
+                                endif
+                              enddo
+                              enddo
+                            enddo
+!rv,sgi>
+                           !
+                           !Dump it to the output file.
+                           !
+                           CALL mpp_write(ig_units(il_port),crnlonij(il_port),loncrn)
+                           DEALLOCATE(rl_lonscrn)
+                           DEALLOCATE(loncrn)
+                       ENDIF
+                     ENDDO
+
+                     IF (ll_notfound) WRITE(nulprt,*)'psmile_def_metdata: No corner longitudes found' &
+                              ,'for grid', cga_clim_locator(il_port)
+
+!rv,sgi                       DEALLOCATE(lon)
+                     !
+                     !Latitude corners
+                     !
+                     !See comments above.
+                     !
+                       clstrg = cga_clim_locator(il_port)//crn_clim_latsuf
+                       ll_notfound = .TRUE.
+
+                       DO il_i=1,il_nvar
+
+                     
+                       CALL mpp_get_atts(il_vars(il_i),name=cl_varname,siz=lens_lat)
+                       IF(TRIM(cl_varname).EQ.TRIM(clstrg) ) THEN
+                           ll_notfound = .FALSE.
+#ifdef __VERBOSE
+                           write(nulprt,*) &
+                           'psmile_def_metada, lat, clstrg: ',clstrg,lens_lat
+#endif
+                           nbr_corners(il_port)=lens_lat(3)
+                           ALLOCATE(rl_latscrn(lens_lat(1),lens_lat(2) &
+                                   ,nbr_corners(il_port)))
+                           ALLOCATE(latcrn(nbr_corners(il_port) &
+                                   ,1:il_xend-il_xbegin+1 &
+                                   ,1:il_yend-il_ybegin+1))
+                           lens_lat(1)=il_xend-il_xbegin+1
+                           lens_lat(2)=il_yend-il_ybegin+1
+                           lens_lat(3)=nbr_corners(il_port)
+
+                           CALL mpp_read(nc_grdid,il_vars(il_i),rl_latscrn,tindex=1)
+!rv,sgi<
+                           if((ig_def_invert(il_port).gt.1).or. &
+                              (ig_def_reverse(il_port).gt.1)) then
+                             llxlon=ig_def_invert(il_port).eq.3  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.3  &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             llylat=ig_def_invert(il_port).eq.2  &
+                                .or.ig_def_invert(il_port).eq.5  &
+                                .or.ig_def_reverse(il_port).eq.2 &
+                                .or.ig_def_reverse(il_port).eq.5  
+                             call inv2dcrn(rl_latscrn,lens_lat(1),lens_lat(2) &
+                                          ,nbr_corners(il_port),llxlon,llylat)
+                           endif
+!rv,sgi>
+
+                           call transp_crn2cf(rl_latscrn,latcrn,lens_lat)
+                           call mpp_write(ig_units(il_port),crnlatij(il_port),latcrn)
+                           DEALLOCATE(rl_latscrn)
+                           DEALLOCATE(latcrn)
+                       ENDIF
+                     ENDDO
+                     IF (ll_notfound) WRITE(nulprt,*)'psmile_def_metdata: No corner latitudes found' &
+                              ,'for grid', cga_clim_locator(il_port)
+                     DEALLOCATE(lat)
+                                            
+!rv,sgi<
+                     if(ALLOCATED(lon)) DEALLOCATE(lon)
+!rv,sgi>
+                     DEALLOCATE(il_vars)
+                 ENDIF
+
+                 CALL mpp_flush(ig_units(il_port))
+
+             ENDIF
+
+         ENDIF
+#ifdef __VERBOSE
+       write(nulprt,*)'End -- psmile_def_metada'
+       call flush(nulprt)
+#endif
+     ENDDO
+       end subroutine psmile_def_metadata
+
+       subroutine psmile_close_files(id_error)
+!------------------------------------------------------------------------------
+!      This subroutine closes all opened psmile_io files 
+!      Supposed to be called in prism_terminate before  psmile_io_cleanup
+!      and before shutting down MPI!
+!-----------------------------------------------------------------------
+!
+       use mod_kinds_model   
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+       implicit none
+
+#include <mpif.h>
+       integer(kind=ip_intwp_p),intent(out)::id_error
+!Local variables
+       integer(kind=ip_intwp_p)::il_port
+
+       if( ig_color.ne.1000*ig_mynummod) return
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_close_files: Start'
+#endif
+       id_error=CLIM_Ok
+
+       do il_port=1,nports
+!          IF (ig_def_state(il_port) .eq. ip_ignout .or. &
+!            ig_def_state(il_port) .eq. ip_expout .or. &
+!            ig_def_state(il_port) .eq. ip_output .or. &
+!            ig_def_state(il_port) .eq. ip_input ) THEN
+!RV:22.01.2003
+!Just in case that ig_def_state has been deallocated during termination.
+!This way has less interference with rest of prism_terminate.
+          IF (ig_units(il_port).gt.0) THEN
+             IF (allocated(dg_times).and. &
+                 associated(dg_times(il_port)%rl_times)) THEN
+
+               deallocate(dg_times(il_port)%rl_times)
+
+             ENDIF
+
+             call mpp_close(ig_units(il_port))
+
+          ENDIF
+       enddo
+
+!RV: 18.12.2002: Moved these lines into psmile_io_cleanup
+!       call mpp_io_exit()
+!       call mpp_domains_exit()
+!       call mpp_exit()
+
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_close_files: End'
+#endif
+       
+       end subroutine psmile_close_files
+
+       subroutine psmile_io_cleanup(id_error)
+!-----------------------------------------------------------------------
+!      Supposed to be called in prism_terminate after psmile_close_files
+!-----------------------------------------------------------------------
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+
+       integer(kind=ip_intwp_p),intent(out)::id_error
+
+       if( ig_color.ne.1000*ig_mynummod) return
+!Global arrays to specify IO domains
+       if(allocated(domain))deallocate(domain)
+       if(allocated(xdom))deallocate(xdom)
+       if(allocated(ydom))deallocate(ydom)
+       if(allocated(lg_is_odd_distribution))deallocate(lg_is_odd_distribution)
+
+!Global arrarys for opening files)
+       if(allocated(ig_units))deallocate(ig_units)
+       if(allocated(ig_action))deallocate(ig_action)
+       if(allocated(ig_form))deallocate(ig_form)
+       if(allocated(ig_threading))deallocate(ig_threading)
+       if(allocated(ig_fileset))deallocate(ig_fileset)
+ 
+!Global arrays for netcdf metadata informations)
+       if(allocated(ig_var_index))deallocate(ig_var_index)
+       if(allocated(ig_ntimes))deallocate(ig_ntimes)
+       if(allocated(dg_times))deallocate( dg_times)
+       if(allocated(ig_vars))deallocate(ig_vars)
+       if(allocated(field))deallocate(field)
+       if(allocated(latij))deallocate(latij)
+       if(allocated(lonij))deallocate(lonij)
+       if(allocated(x_axis))deallocate(x_axis)
+       if(allocated(y_axis))deallocate(y_axis)
+       if(allocated(t_axis))deallocate(t_axis)
+
+!Was not allocated. Oasis sends 2D arrays. In case of bundles or 3d arrays
+!we have to declare z_axis + plus one for bundles.
+       if(allocated(z_axis))deallocate(z_axis)
+
+! These arrays are supposed to be part of a different module!)
+! However, no information is available in Oasis 3.0. So, let them live here)
+! for a while.)
+       
+       if(allocated(cports_lgname)) deallocate(cports_lgname)
+       if(allocated(cports_units)) deallocate(cports_units)
+
+       call mpp_io_exit()
+       call mpp_domains_exit()
+       call mpp_exit()
+
+
+       end subroutine psmile_io_cleanup
+
+       subroutine psmile_read_8(id_port_id,rd_field,id_newtime)
+!--------------------------------------------------------------------------
+!       Called in rism_get
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+
+       integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+       REAL(kind=ip_double_p),DIMENSION(myport(4,id_port_id)), &
+                                                  intent(out) :: rd_field
+!local
+       real(kind=ip_double_p)::rl_time
+       integer(kind=ip_intwp_p)::il_record_no
+       real(kind=ip_double_p)::diff_first,diff_i
+       integer(kind=ip_intwp_p)::il_i,i
+
+#ifdef __VERBOSE
+       write(nulprt,*) 'psmile_read_8: Start'
+       call flush(nulprt)
+#endif
+
+!RV:22.01.2003
+
+#ifdef __READ_BY_LOOKUP
+!I try to find the record number of timestamp id_newtime by scrolling through
+!the time stamps of the file.
+
+       rl_time=id_newtime
+       if(.not.associated(dg_times(id_port_id)%rl_times))then
+
+         allocate(dg_times(id_port_id)%rl_times(1:ig_ntimes(id_port_id)))
+         call mpp_get_times( ig_units(id_port_id) &
+                           ,dg_times(id_port_id)%rl_times(:))
+       endif
+!       il_record_no=minloc(abs(dg_times(id_port_id)%rl_times-rl_time),dim=1)
+       il_record_no=1
+       diff_first=abs(dg_times(id_port_id)%rl_times(1)-rl_time)
+       do i=1,ig_ntimes(id_port_id)
+     	   diff_i=abs(dg_times(id_port_id)%rl_times(i)-rl_time)
+    	   if(abs(diff_i).lt.diff_first) then
+        	diff_first=diff_i
+        	il_record_no=i
+    	   endif
+       enddo
+       if(abs(dg_times(id_port_id)%rl_times(il_record_no)-rl_time).gt.1.d-8) &
+       then
+         write(nulprt,*)'psmile_read_8: The time stamp ',id_newtime, &
+                        ' is not available in file ',cg_def_inpfile(id_port_id)
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_read_8: timestamp, record no.',id_newtime, &
+	              il_record_no
+       call flush(nulprt)
+#endif
+#else
+!Alternative:
+!Assuming that time stamps are starting from zero
+       il_record_no=id_newtime/ig_def_freq(id_port_id) +1
+#endif
+       
+       call mpp_read(ig_units(id_port_id),ig_vars(id_port_id) &
+                    ,domain(id_port_id),rd_field,il_record_no)
+
+#ifdef __VERBOSE
+       write(nulprt,*) 'psmile_read_8: End'
+       call flush(nulprt)
+#endif
+       end subroutine psmile_read_8
+
+       subroutine psmile_read_4(id_port_id,rd_field,id_newtime)
+!--------------------------------------------------------------------------
+!       Called in prism_get
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+
+       integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+       REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+!local
+       REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field
+       real(kind=ip_double_p)::rl_time
+       integer(kind=ip_intwp_p)::il_record_no,il_i
+
+#ifdef __VERBOSE
+       write(nulprt,*) 'psmile_read_4: Start'
+#endif
+
+!RV:22.01.2003
+#ifdef __READ_BY_LOOKUP
+!I try to find the record number of timestamp id_newtime by scrolling through
+!the time stamps of the file.
+       rl_time=id_newtime
+
+       if(.not.associated(dg_times(id_port_id)%rl_times))then
+
+         allocate(dg_times(id_port_id)%rl_times(1:ig_ntimes(id_port_id)))
+         call mpp_get_times( ig_units(id_port_id), &
+                           dg_times(id_port_id)%rl_times(:))
+
+       endif
+
+       il_record_no=minloc(abs(dg_times(id_port_id)%rl_times-rl_time),dim=1)
+
+       if(abs(dg_times(id_port_id)%rl_times(il_record_no)-rl_time).gt.1.d-8) &
+       then
+         write(nulprt,*)'psmile_read_4: The time stamp ',id_newtime, &
+                        ' is not available in file ',cg_def_inpfile(id_port_id)
+         call flush(nulprt)
+         call MPI_ABORT(mpi_comm,0,mpi_err)
+       endif
+#ifdef __VERBOSE
+       write(nulprt,*)'psmile_read_4: timestamp, record no.',id_newtime, &
+	              il_record_no
+       call flush(nulprt)
+#endif
+#else
+!Alternative:
+!Assuming that time stamps are starting from zero
+       il_record_no=id_newtime/ig_def_freq(id_port_id) +1
+#endif
+       
+       call mpp_read(ig_units(id_port_id),ig_vars(id_port_id) &
+                    ,domain(id_port_id),rl_field,il_record_no)
+       rd_field=rl_field
+
+#ifdef __VERBOSE
+       write(nulprt,*) 'psmile_read_4: End'
+       call flush(nulprt)
+#endif
+       end subroutine psmile_read_4
+
+       subroutine psmile_write_4(id_port_id,rd_field,id_newtime)
+!--------------------------------------------------------------------------
+!       Called in prism_get or prism_put
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+       integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+       REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
+!Local
+       real(kind=ip_double_p)::rl_time
+       real(ip_double_p),DIMENSION(myport(4,id_port_id)) ::rl_field
+
+#ifdef __VERBOSE
+       write(nulprt,*)' psmile_write_4: Start'
+#endif
+       rl_time=id_newtime
+       rl_field=rd_field
+       call mpp_write(ig_units(id_port_id),field(id_port_id) &
+                              ,domain(id_port_id),rl_field,rl_time)
+#ifdef __VERBOSE
+       write(nulprt,*)' psmile_write_4: End'
+#endif
+
+       end subroutine psmile_write_4
+
+       subroutine psmile_write_8(id_port_id,rd_field,id_newtime)
+!--------------------------------------------------------------------------
+!       Called in prism_get or prism_put
+       use mod_kinds_model
+       use mod_prism_proto
+       use mod_comprism_proto
+       use mod_psmile_io
+
+       implicit none
+       integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+       integer(kind=ip_intwp_p)::il_stat
+       REAL(kind=ip_double_p), &
+          DIMENSION(1:myport(4,id_port_id)),intent(inout) :: rd_field
+!Local
+       real(kind=ip_double_p)::rl_time
+       integer(kind=ip_intwp_p) :: ij
+
+!       write(70+mpi_rank+(ig_color/1000-1)*4,'(4e12.5)')rd_field
+#ifdef __VERBOSE
+       write(nulprt,*)' psmile_write_8: Start'
+       call flush(nulprt)
+#endif
+       rl_time=id_newtime
+#ifdef __VERBOSE
+       write(nulprt,*)'rl_time ',rl_time
+#endif
+!       do ij =1,4608,4608/10
+!          write(nulprt,*)'rd_field bef mpp_write ',rd_field(ij)
+!       enddo
+!       call flush(nulprt)
+       call mpp_write(ig_units(id_port_id),field(id_port_id) &
+                              ,domain(id_port_id),rd_field,rl_time)
+
+#ifdef __VERBOSE
+       write(nulprt,*)' psmile_write_8: End'
+       call flush(nulprt)
+#endif
+       end subroutine psmile_write_8
+
+       subroutine indexi(n,arr,indx)
+!---------------------------------------------------------------------
+! Generates a list indx which sorts arr in ascending order.
+! This is called sorting by indexing.
+! Code taken from 'Numerical Recipes'
+!---------------------------------------------------------------------
+      use mod_kinds_model
+      INTEGER(KIND=IP_INTWP_P),intent(in):: n
+      INTEGER(KIND=IP_INTWP_P),intent(out)::indx(n)
+      integer(kind=ip_intwp_p),intent(in):: arr(n)
+!Local
+      integer(kind=ip_intwp_p),PARAMETER:: M=7,NSTACK=128
+      INTEGER(KIND=IP_INTWP_P):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK)
+      integer(kind=ip_intwp_p):: a
+
+      do 11 j=1,n
+        indx(j)=j
+11    continue
+      jstack=0
+      l=1
+      ir=n
+1     if(ir-l.lt.M)then
+        do 13 j=l+1,ir
+          indxt=indx(j)
+          a=arr(indxt)
+          do 12 i=j-1,1,-1
+            if(arr(indx(i)).le.a)goto 2
+            indx(i+1)=indx(i)
+12        continue
+          i=0
+2         indx(i+1)=indxt
+13      continue
+        if(jstack.eq.0)return
+        ir=istack(jstack)
+        l=istack(jstack-1)
+        jstack=jstack-2
+      else
+        k=(l+ir)/2
+        itemp=indx(k)
+        indx(k)=indx(l+1)
+        indx(l+1)=itemp
+        if(arr(indx(l+1)).gt.arr(indx(ir)))then
+          itemp=indx(l+1)
+          indx(l+1)=indx(ir)
+          indx(ir)=itemp
+        endif
+        if(arr(indx(l)).gt.arr(indx(ir)))then
+          itemp=indx(l)
+          indx(l)=indx(ir)
+          indx(ir)=itemp
+        endif
+        if(arr(indx(l+1)).gt.arr(indx(l)))then
+          itemp=indx(l+1)
+          indx(l+1)=indx(l)
+          indx(l)=itemp
+        endif
+        i=l+1
+        j=ir
+        indxt=indx(l)
+        a=arr(indxt)
+3       continue
+          i=i+1
+        if(arr(indx(i)).lt.a)goto 3
+4       continue
+          j=j-1
+        if(arr(indx(j)).gt.a)goto 4
+        if(j.lt.i)goto 5
+        itemp=indx(i)
+        indx(i)=indx(j)
+        indx(j)=itemp
+        goto 3
+5       indx(l)=indx(j)
+        indx(j)=indxt
+        jstack=jstack+2
+        if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx'
+        if(ir-i+1.ge.j-l)then
+          istack(jstack)=ir
+          istack(jstack-1)=i
+          ir=j-1
+        else
+          istack(jstack)=j-1
+          istack(jstack-1)=l
+          l=i
+        endif
+      endif
+      goto 1
+      END subroutine indexi
+
+      subroutine combine_with_date(cd_in,cd_mode,id_initial_date,cd_on)
+!-------------------------------------------------------------
+      use mod_kinds_model
+      character(len=*),intent(in)::cd_in
+      character(len=*),intent(in)::cd_mode
+      character(len=*),intent(out)::cd_on
+      integer(kind=ip_intwp_p),intent(in)::id_initial_date(:)
+!Local
+      integer(kind=ip_intwp_p),parameter::il_nsuffixes=2
+      integer(kind=ip_intwp_p)::leni,leno,lens,lenb,il_i
+      character(len=8)::suffixes(il_nsuffixes),suffix
+      character(len=len(cd_in))::cl_basename
+      character(len=4)::cl_year
+      character(len=2)::cl_date(1:size(id_initial_date)-1)
+     
+      suffixes(1)='.nc'
+      suffixes(2)='.grib'
+     
+      leni=len(trim(cd_in))
+      leno=len(cd_on)
+     
+      do il_i=1,il_nsuffixes
+     
+        suffix=suffixes(il_i)
+        lens=len(trim(suffix))
+      
+        if(cd_in(leni-lens+1:leni).eq.suffix(1:lens)) then
+          cl_basename(1:leni-lens)=cd_in(1:leni-lens)
+          lenb=leni-lens
+          EXIT
+        else
+          cl_basename(1:leni)=cd_in(1:leni)
+          lenb=leni
+          suffix='.nc'
+        endif
+     
+      enddo
+     
+     
+      write(cl_year,'(i4.4)')id_initial_date(1)
+
+      do il_i=2,size(id_initial_date)
+
+        write(cl_date(il_i-1),'(i2.2)')id_initial_date(il_i)
+
+      enddo
+     
+      if(trim(cd_mode) .eq. 'since' ) then
+      cd_on=trim(cl_basename(1:lenb))//' '//trim(cd_mode)//' ' &
+                                     //cl_year//'-'//cl_date(1)//'-' &
+                                     //cl_date(2)//' ' &
+                                     //cl_date(3)//':' &
+                                     //cl_date(4)//':' &
+                                     //cl_date(5)
+      else
+      cd_on=trim(cl_basename(1:lenb))//'_'//trim(cd_mode)//'.' &
+                                     //cl_year//'-'//cl_date(1)//'-' &
+                                     //cl_date(2)//'T' &
+                                     //cl_date(3)//':' &
+                                     //cl_date(4)//':' &
+                                     //cl_date(5)//suffix
+      endif
+     
+      return
+      end subroutine combine_with_date
+
+      subroutine transp_crn2cf(x,y,vshape)
+        use mod_kinds_model
+        implicit none
+!       Input parameters
+        Integer, Intent(in):: vshape(3)
+        REAL(kind=ip_realwp_p),Intent(in)::x(vshape(1),vshape(2),vshape(3))
+!       Ouput parameters
+        REAL(kind=ip_realwp_p),Intent(out)::y(vshape(3),vshape(1),vshape(2))
+!Local
+        integer::il_i,il_j,il_k
+
+        do il_k=1,vshape(3)
+          do il_j=1,vshape(2)
+            do il_i=1,vshape(1)
+              y(il_k, il_i, il_j)=x(il_i ,il_j, il_k)
+            enddo
+          enddo
+        enddo
+
+      end subroutine transp_crn2cf
+
+!rv,sgi<
+      subroutine inv2d(x,ilon,ilat,lxlon,lylat)
+        use mod_kinds_model
+        use mod_comprism_proto
+        implicit none
+!
+!     Input Parameters
+!
+        Integer,Intent(In)::ilon,ilat
+        REAL(kind=ip_realwp_p)::x(ilon,ilat)
+        Logical,Intent(In)::lxlon,lylat
+!
+!     Local Variables
+!
+        REAL(kind=ip_realwp_p)::xtmp
+        Integer(kind=ip_realwp_p):: ijmed,iimed,ji,jj
+#ifdef __VERBOSE
+       write(nulprt,*)'inv2d start:',ilon,ilat,lxlon,lylat
+       call flush(nulprt)
+#endif
+!
+!       Reorder lattitude related values stored as the y-direction.
+!
+        if(lylat) then
+          ijmed = ilat/2
+          DO jj = 1, ijmed
+            DO ji = 1, ilon
+              xtmp = x(ji,ilat + 1 - jj)
+              x(ji,ilat + 1 - jj) = x(ji,jj)
+              x(ji,jj) = xtmp
+            ENDDO
+          ENDDO
+        endif
+
+!
+!       Reorder longitude related values stored as the x-direction.
+!
+        if(lxlon) then
+          iimed = ilon/2
+          DO  jj = 1, ilat
+            DO  ji = 1, iimed
+              xtmp = x(ilon + 1 - ji,jj)
+              x(ilon + 1 - ji,jj) = x(ji,jj)
+              x(ji,jj) = xtmp
+            ENDDO
+          ENDDO
+        endif
+
+#ifdef __VERBOSE
+       write(nulprt,*)'inv2d end'
+       call flush(nulprt)
+#endif
+        
+      end subroutine inv2d
+
+      subroutine inv2dcrn(x,ilon,ilat,icrn,lxlon,lylat)
+        use mod_kinds_model
+        use mod_comprism_proto
+        implicit none
+!
+!     Input Parameters
+!
+        Integer,Intent(In)::ilon,ilat,icrn
+        REAL(kind=ip_realwp_p)::x(ilon,ilat,icrn)
+        Logical,Intent(In)::lxlon,lylat
+!
+!     Local Variables
+!
+        REAL(kind=ip_realwp_p)::xtmp
+        Integer(kind=ip_realwp_p):: ijmed,iimed,ji,jj,jc
+#ifdef __VERBOSE
+       write(nulprt,*)'inv2dcrn start:',ilon,ilat,icrn,lxlon,lylat
+       call flush(nulprt)
+#endif
+!
+!       Reorder corners of lattitude 
+!
+        if(lylat) then
+          ijmed = ilat/2
+          DO jc=1,icrn
+            DO jj = 1, ijmed
+              DO ji = 1, ilon
+                xtmp = x(ji,ilat + 1 - jj,jc)
+                x(ji,ilat + 1 - jj,jc) = x(ji,jj,jc)
+                x(ji,jj,jc) = xtmp
+              ENDDO
+            ENDDO
+          ENDDO
+        endif
+
+!
+!       Reorder corners of longitude 
+!
+        if(lxlon) then
+          iimed = ilon/2
+          DO jc=1,icrn
+            DO  jj = 1, ilat
+              DO  ji = 1, iimed
+                xtmp = x(ilon + 1 - ji,jj,jc)
+                x(ilon + 1 - ji,jj,jc) = x(ji,jj,jc)
+                x(ji,jj,jc) = xtmp
+              ENDDO
+            ENDDO
+          ENDDO
+        endif
+
+        
+#ifdef __VERBOSE
+       write(nulprt,*)'inv2dcrn end'
+       call flush(nulprt)
+#endif
+      end subroutine inv2dcrn
+!rv,sgi>
Index: CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io_interfaces.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io_interfaces.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/mod_psmile_io_interfaces.F90	(revision 1677)
@@ -0,0 +1,121 @@
+!-----------------------------------------------------------------------
+! BOP
+!
+! !MODULE:  mod_psmile_io_interfaces
+! !REMARKS: Programed by Reiner Vogelsang, SGI (reiner@sgi.com)
+!
+! !USES: psmile_os.h
+! !DESCRIPTION:
+!  Defines F90 interfaces of all PSMILe I/O routines
+!
+! !REVISION HISTORY:
+! 2003.04.28 Reiner Vogelsang
+!       - Screening of 4 byte real interfaces.
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: mod_psmile_io_interfaces.F90,v 1.1.1.1 2005/03/23 16:01:10 adm Exp $
+!-----------------------------------------------------------------------
+!
+!RV: Set here some OS specific preprocessor flags
+!
+#include "psmile_os.h" 
+!
+       module mod_psmile_io_interfaces
+       interface psmile_io_init_comp
+         subroutine psmile_io_init_comp(id_error)
+            use mod_kinds_model
+            integer(kind=ip_intwp_p),intent(out)::id_error
+         end subroutine psmile_io_init_comp
+       end interface
+
+       interface  psmile_def_domains
+	 subroutine psmile_def_domains(id_error)
+            use mod_kinds_model
+           integer(kind=ip_intwp_p),intent(out)::id_error
+	 end subroutine psmile_def_domains
+       end interface
+
+       interface psmile_def_files
+         subroutine psmile_def_files(id_error)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(out)::id_error
+         end subroutine psmile_def_files
+       end interface
+
+       interface psmile_def_metadata
+         subroutine psmile_def_metadata(id_error)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(out)::id_error
+         end subroutine psmile_def_metadata
+       end interface
+
+       interface psmile_close_files
+         subroutine psmile_close_files(id_error)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(out)::id_error
+         end subroutine psmile_close_files
+       end interface
+
+       interface psmile_io_cleanup
+         subroutine psmile_io_cleanup(id_error)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(out)::id_error
+         end subroutine psmile_io_cleanup
+       end interface
+
+       interface psmile_read
+
+	 subroutine psmile_read_8(id_port_id,rd_field,id_newtime)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+           REAL(kind=ip_double_p), DIMENSION(:) :: rd_field
+	 end subroutine psmile_read_8
+
+#ifndef __NO_4BYTE_REALS
+   	 subroutine psmile_read_4(id_port_id,rd_field,id_newtime)
+               use mod_kinds_model
+   	   integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+              REAL(kind=ip_single_p), DIMENSION(:) :: rd_field
+   	 end subroutine psmile_read_4
+#endif
+
+       end interface
+
+       interface psmile_write
+	 subroutine psmile_write_8(id_port_id,rd_field,id_newtime)
+            use mod_kinds_model
+	   integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+           REAL(kind=ip_double_p), DIMENSION(:) :: rd_field
+	 end subroutine psmile_write_8
+
+#ifndef __NO_4BYTE_REALS
+   	 subroutine psmile_write_4(id_port_id,rd_field,id_newtime)
+               use mod_kinds_model
+   	   integer(kind=ip_intwp_p),intent(in)::id_newtime,id_port_id
+              REAL(kind=ip_single_p), DIMENSION(:) :: rd_field
+   	 end subroutine psmile_write_4
+#endif 
+
+       end interface
+
+       interface indexi
+	 subroutine indexi(n,arr,indx)
+            use mod_kinds_model
+	 integer(kind=ip_intwp_p),intent(in)::n
+	 integer(kind=ip_intwp_p),intent(in)::arr(n)
+	 integer(kind=ip_intwp_p),intent(out)::indx(n)
+	 end subroutine indexi
+       end interface
+
+       interface combine_with_date
+         subroutine combine_with_date(cd_in,cd_mode,id_initial_date,cd_on)
+            use mod_kinds_model
+         character(len=*),intent(in)::cd_in
+         character(len=*),intent(in)::cd_mode
+	 integer(kind=ip_intwp_p),intent(in)::id_initial_date(:)
+         character(len=*),intent(out)::cd_on
+         end subroutine combine_with_date
+       end interface
+
+       end module  mod_psmile_io_interfaces
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_abort_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_abort_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_abort_proto.F	(revision 1677)
@@ -0,0 +1,49 @@
+      SUBROUTINE prism_abort_proto(id_compid, cd_routine, cd_message)
+C--------------------------------------------------------------------
+C BOP
+C
+C !ROUTINE:  prism_abort_proto
+C
+C !INTERFACE:
+C -----------
+C    ierror: returned error code
+C     
+C !DESCRIPTION:
+C
+C - stop the whole MPI coupled model.
+C
+C !REVISION HISTORY:
+C 03.07.15  S. Legutke - created
+C 03.07.22  S. Valcke - revised
+C
+C EOP
+C--------------------------------------------------------------------
+C $Id: prism_abort_proto.F,v 1.1.1.1 2005/03/23 16:01:10 adm Exp $
+C--------------------------------------------------------------------
+C 
+      USE mod_comprism_proto
+      IMPLICIT NONE
+#include <mpif.h>
+C--------------------------------------------------------------------
+      INTEGER,          INTENT(in) :: id_compid
+      CHARACTER(len=*), INTENT(in) :: cd_routine
+      CHARACTER(len=*), INTENT(in) :: cd_message
+      INTEGER                      :: ierror
+
+      WRITE (*,'(a,a,a,a,a)') 'Calling MPI_ABORT in ',cd_routine, 
+     $    ' by model ',cg_modnam(id_compid),':'
+      WRITE (*,'(a,a)')   '        ',cd_message
+
+
+      CALL MPI_ABORT (mpi_comm, 0, ierror)
+
+      IF (ierror /= MPI_SUCCESS) THEN
+          WRITE (*,'(a)') ' MPI_ABORT failed'
+          WRITE (*,'(a,i4)') ' Error =  ', ierror
+          STOP
+      END IF
+
+      END 
+
+
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_def_var_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_def_var_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_def_var_proto.F	(revision 1677)
@@ -0,0 +1,260 @@
+      SUBROUTINE prism_def_var_proto(id_nports, cdport, id_part, 
+     $     id_var_nodims, kinout, id_var_shape, ktype, kinfo)
+c     
+c     **** Def_var ***   PRISM 1.0
+c     
+c     purpose:
+c     --------
+c        define a port
+c
+c     interface:
+c     ----------
+c        id_nports : port number of the field
+c        cdport : symbolic name of the field
+c        id_part : field decomposition 
+c        id_var_nodims(1) : rank of array variable
+c        id_var_nodims(2) : number of bundles
+c        kinout : port status in/out
+c        id_var_shape : description of the local partition in the 
+c                       global index space
+c        ktype  : type of data
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-1
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c
+c     ----------------------------------------------------------------
+      USE mod_kinds_model
+      USE mod_prism_proto
+      USE mod_comprism_proto
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       kinout, ktype, kinfo, id_nports, 
+     $    id_part
+      INTEGER (kind=ip_intwp_p)       id_var_nodims(2), 
+     $    id_var_shape(2*id_var_nodims(1))
+      CHARACTER*(*) cdport
+c     ----------------------------------------------------------------
+c
+c*    0. First Check
+c     --------------
+c
+      IF ( nexit.NE.1 ) THEN
+         kinfo = CLIM_FastExit
+         WRITE(nulprt,FMT='(A)') 'Def_var - should not be called'
+         GO TO 1010
+      ENDIF
+      kinfo = CLIM_Ok
+c
+c*    1. define the port
+c     ------------------
+c
+      WRITE(nulprt,*) 'Def_var - port name, status : ',cdport, kinout
+      WRITE(nulprt,*) 'Def_var - data type: ',ktype
+c
+      IF ( ktype .ne. PRISM_Real ) THEN
+          WRITE(nulprt,FMT='(A,I4)')
+     $        'Def_var - ERROR - Bad data type:',ktype
+          WRITE(nulprt,*)
+     $        'Calling MPI_Abort in prism_def_var'
+          CALL FLUSH(nulprt)
+          CALL MPI_ABORT (mpi_comm, 0, ierror)
+      ENDIF
+c
+      IF ( kinout.EQ.CLIM_InOut ) THEN
+         CALL prism_defport (id_nports, cdport, CLIM_In, ktype, id_part, 
+     $        kinfo )
+         IF (kinfo.EQ.CLIM_Ok) THEN
+            CALL prism_defport (id_nports, cdport, CLIM_Out, ktype, 
+     $           id_part, kinfo )
+         ENDIF
+      ELSE
+         CALL prism_defport ( id_nports,cdport, kinout, ktype, id_part, 
+     $        kinfo )
+      ENDIF
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CALL FLUSH(nulprt)
+      RETURN
+      END 
+c
+c ====================================================================
+
+      SUBROUTINE prism_defport(id_nports,cdport,kinout,ktype,id_part,
+     $     kinfo)
+c
+c*    *** Define ***   CLIM 2.2
+c
+c     purpose:
+c     --------
+c        define a port
+c
+c     interface:
+c     ----------
+c        id_nports : port number of the field
+c        cdport : symbolic name of the field
+c        kinout : port status in/out
+c        ktype  : type of data
+c        kparal : type of parallel decomposition
+c        kinfo  : output status
+c
+c     lib mp:
+c     -------
+c        mpi-2
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c
+c     ----------------------------------------------------------------
+      USE mod_kinds_model
+      USE mod_prism_proto
+      USE mod_comprism_proto
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       kinout, ktype, kinfo
+      CHARACTER*(*) cdport
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)    ip, id_nports, id_part, ierror
+      REAL(kind=ip_realwp_p)          rl_testvar
+      REAL(kind=ip_double_p)   dl_testvar
+      CHARACTER*32  cltest
+c     ----------------------------------------------------------------
+c
+      rl_testvar = 0.0_ip_realwp_p
+      dl_testvar = 0.0_ip_double_p
+c
+c*    1. check if this port already exist
+c     -----------------------------------
+c
+      cltest= cdport
+c
+      DO ip=1,nports
+         IF (cltest.EQ.cports(ip).AND.kinout.EQ.myport(1,ip)) THEN
+            kinfo = PRISM_DoubleDef
+            WRITE(nulprt,FMT='(A,A)')
+     $           'Def_var - WARNING - duplicate definition of port ',
+     $           cdport
+            GO TO 1010
+         ENDIF
+      ENDDO
+c     
+c*    2. save arguments as half a link
+c     --------------------------------
+c
+      nports = nports + 1
+      id_nports = nports
+      DO il=1, ig_clim_nfield
+        IF (cltest.EQ.cg_cnaminp(il).or.cltest.eq.cg_cnamout(il)) THEN
+            IF (cltest .EQ. cg_cnaminp(il)) then
+                cga_clim_locator(nports) = cga_clim_locatorbf(il)
+            ELSE IF (cltest .EQ. cg_cnamout(il)) then
+                cga_clim_locator(nports) = cga_clim_locatoraf(il)
+            ENDIF
+            IF (ig_clim_state(il) .eq. ip_exported .or. 
+     $           ig_clim_state(il) .eq. ip_expout .or. 
+     $           ig_clim_state(il) .eq. ip_auxilary) THEN 
+               cports(nports) = cltest
+               ig_def_lag(nports)=ig_clim_lag(il)
+!AC
+               IF (cltest.EQ.cg_cnamout(il)) THEN 
+                   ig_def_reverse(nports)=ig_clim_reverse(il)
+               ELSEIF  (cltest.EQ.cg_cnaminp(il)) THEN
+                   ig_def_invert(nports)=ig_clim_invert(il)
+               ENDIF
+!AC
+               ig_def_freq(nports)=ig_clim_freq(il)
+               ig_def_seq(nports)=ig_clim_seq(il)
+               cg_def_rstfile(nports)=cg_clim_rstfile(il)
+               ig_def_norstfile(nports)=ig_clim_norstfile(il)
+               ig_def_state(nports)=ig_clim_state(il)
+               ig_def_trans(nports)=ig_clim_trans(il)
+               cg_def_inpfile(nports)=cg_clim_inpfile(il)
+!RV
+               ig_def_numlab(nports)=ig_clim_numlab(il)
+!RV
+            ELSE
+               IF (ig_clim_state(il) .eq. ip_ignout) 
+     $              cg_ignout_field(nports) = cltest
+               cports(nports) = cg_cnamout(il)
+               ig_def_lag(nports)=ig_clim_lag(il)
+!AC
+               IF (cltest.EQ.cg_cnamout(il)) THEN 
+                   ig_def_reverse(nports)=ig_clim_reverse(il)
+               ELSEIF  (cltest.EQ.cg_cnaminp(il)) THEN
+                   ig_def_invert(nports)=ig_clim_invert(il)
+               ENDIF
+!AC
+               ig_def_freq(nports)=ig_clim_freq(il)
+               ig_def_seq(nports)=ig_clim_seq(il)
+               cg_def_rstfile(nports)=cg_clim_rstfile(il)
+               ig_def_norstfile(nports)=ig_clim_norstfile(il)
+               ig_def_state(nports)=ig_clim_state(il)
+               ig_def_trans(nports)=ig_clim_trans(il)
+               cg_def_inpfile(nports)=cg_clim_inpfile(il)
+!RV
+               ig_def_numlab(nports)=ig_clim_numlab(il)
+!RV
+            ENDIF
+         ENDIF
+      ENDDO
+c     
+      IF (ig_def_freq(nports) .eq. 0) THEN
+         WRITE(nulprt,FMT=*) 
+     $      'Def_var - WARNING '
+         WRITE(nulprt,FMT=*) 
+     $      'You have a file which is not defined in the namcouple '
+         WRITE(nulprt,FMT=*) 
+     $        'This file will not be exchanged !'
+         GOTO 1010
+      ELSEIF (ig_def_freq(nports) .gt. ig_ntime) THEN
+         WRITE(nulprt,FMT=*) 
+     $        'Def_var - WARNING '
+         WRITE(nulprt,FMT=*) 
+     $        'You have a file defined with a coupling period greater '
+         WRITE(nulprt,FMT=*) 
+     $        'than the time of the simulation. So, this file will not '
+         WRITE(nulprt,FMT=*) 
+     $        'be exchanged !'
+         GOTO 1010 
+      ELSE
+         myport(1,nports) = kinout
+         myport(5,nports) = 0
+c     
+c         IF ( ktype.EQ.CLIM_Integer ) THEN
+c            WRITE(nulprt,FMT=*) 
+c     $ ' Communication with integer as type of data is not supported'
+c            call flush(nulprt)
+c            call MPI_ABORT (mpi_comm, 0, ierror)
+c         ELSEIF ( ktype.EQ.PRISM_Real ) THEN
+         IF ( ktype .EQ. PRISM_Real ) THEN
+            myport(2,nports) = PRISM_Real
+            myport(3,nports) = kind(rl_testvar)
+c         ELSEIF ( ktype.EQ.PRISM_Double ) THEN
+c            myport(2,nports) = PRISM_Double
+c            myport(3,nports) = kind(dl_testvar)
+         ELSE
+            kinfo = CLIM_BadType
+            WRITE(nulprt,FMT='(A,I4)')
+     $           'Def_var - WARNING - Bad data type:',ktype
+         ENDIF
+c     
+         mydist (:,nports) = ig_def_part (:,id_part)
+         myport (4,nports) = ig_length_part (id_part)
+      ENDIF
+c
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CALL FLUSH(nulprt)
+      RETURN
+      END 
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_enddef_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_enddef_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_enddef_proto.F	(revision 1677)
@@ -0,0 +1,475 @@
+      SUBROUTINE prism_enddef_proto(kinfo)
+c
+c*    *** Enddef ***   PRISM 1.0
+c
+c     purpose:
+c     --------
+c        beginning of the coupled run
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        mpi-1 or mpi-2
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c        Arnaud Caubel  - FECIT - removed kmxtag as argument
+c
+c     ----------------------------------------------------------------
+      USE mod_kinds_model
+      USE mod_prism_proto
+      USE mod_comprism_proto
+#if !defined key_noIO
+      USE mod_psmile_io_interfaces
+#endif
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) kinfo, il_err, il_max
+      REAL(kind=ip_double_p) rl_testvar
+      INTEGER (kind=ip_intwp_p) il_ibyt, il_bufsendsize,
+     $    il_bufsizebyt, integer_byte_size, ii, io_size, 
+     $    integer_io_size, il_modbufsizebyt, il_modbufsize,
+     $    il_bufsize, il_errhandler
+c     ----------------------------------------------------------------
+c
+      rl_testvar = 0.0_ip_double_p
+c
+c*    0. First Check
+c     --------------
+c
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Enddef - should not be called'
+          GO TO 1010
+      ENDIF
+      kinfo  = CLIM_Ok
+      nexit  = 0
+      il_max = maxval(myport(4,:))
+      ig_maxtype = ig_CLIMmax*kind(rl_testvar)
+      ig_maxtype_field = il_max*kind(rl_testvar)
+c
+      IF (lg_clim_bsend) THEN
+c         Determination of size of dg_bufsend element without kind
+          integer_byte_size = BIT_SIZE(ii)/8
+          INQUIRE (iolength=io_size) ii
+          integer_io_size = io_size
+          INQUIRE (iolength=io_size) rl_testvar
+          il_ibyt = io_size/integer_io_size*integer_byte_size
+c
+c         MPI_BSEND_OVERHEAD/il_ibyt+1 is the number of dg_bufsend
+c         elements needed to store MPI_BSEND_OVERHEAD bytes; there
+c         may be MPI_BSEND_OVERHEAD bytes per message (nports) 
+          il_bufsendsize = (il_max + MPI_BSEND_OVERHEAD/il_ibyt+1)
+     $        * nports
+          WRITE(nulprt,*) 'il_bufsendsize = ', il_bufsendsize
+C 
+C         Test if model has already attached to mpi buffer
+          CALL MPI_Errhandler_set(MPI_COMM_WORLD,
+     $         MPI_ERRORS_RETURN, mpi_err)
+
+          CALL MPI_Buffer_Detach(rl_testvar,il_modbufsizebyt,mpi_err)
+
+          IF (mpi_err .ne. MPI_SUCCESS) THEN
+              il_bufsize = il_bufsendsize
+          ELSE
+              il_modbufsize = il_modbufsizebyt/il_ibyt
+              il_bufsize = il_bufsendsize + il_modbufsize
+              WRITE(nulprt,*) 'il_bufsize = ', il_bufsize
+          ENDIF
+
+          CALL MPI_Errhandler_set(MPI_COMM_WORLD,
+     $        MPI_ERRORS_ARE_FATAL, mpi_err)
+
+          ALLOCATE (dg_bufsend(il_bufsize),  stat = il_err)
+          il_bufsizebyt = il_bufsize * il_ibyt
+          WRITE(nulprt,*) 'il_bufsizebyt = ', il_bufsizebyt
+C 
+C*   Attach a buffer able to contain the number of coupling fields 
+c    (nports) with maximum possible size (il_max) supposed to be declared 
+c    as DOUBLE.  
+          CALL MPI_Buffer_Attach(dg_bufsend, il_bufsizebyt, mpi_err)
+          WRITE(nulprt,*)'Attached buffer of size=',il_bufsizebyt
+c
+      ENDIF
+      ALLOCATE (pkwork_field(il_max), stat = il_err)
+      IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "pkwork_field" allocation in PRISM_enddef !'
+      pkwork_field(:)=0
+c
+      CALL PRISM_Start_MPI(kinfo)
+c
+c*    1. Allocation of arrays used for exchange of fields and local 
+c*    transformations
+c     -----------------------------------------------------
+      ALLOCATE (rg_field_trans(il_max,nports),stat = il_err)
+      IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "rg_field_trans" allocation in PRISM_enddef !'
+      rg_field_trans(:,:)=0
+      ALLOCATE (dg_field_trans(il_max,nports),stat = il_err)
+      IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "dg_field_trans" allocation in PRISM_enddef !'
+      dg_field_trans(:,:)=0
+      ALLOCATE (ig_number(nports),stat = il_err)
+      IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "ig_number" allocation in PRISM_enddef !'
+      ig_number(:) = 0
+c
+c*    2. Get wall clock differences with other models
+c     -----------------------------------------------
+c
+c       2.1 Initilizations
+c       ------------------
+c
+      IF (lg_oasis_field) THEN
+         delta(0:ncplprocs-1)=0.
+         delte(0:ncplprocs-1)=0.
+      ELSE
+         delta(1:ncplprocs)=0.
+         delte(1:ncplprocs)=0.
+      ENDIF
+c
+c*    correct execution
+c
+      nexit = 1
+#if !defined key_noIO
+      call psmile_def_domains(il_err)
+      call psmile_def_files(il_err)
+      call psmile_def_metadata(il_err)
+#endif
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      WRITE (nulprt,FMT='(A)') 'Returning from Enddef -- '
+      CALL FLUSH(nulprt)
+      RETURN
+      END
+      SUBROUTINE PRISM_Start_MPI(kinfo)
+c
+c*    *** Start-mpi ***   CLIM 3.0
+c
+c     purpose:
+c     --------
+c        beginning of the coupled run (MPI-2 only)
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     method:
+c     -------
+c        With MPI2, use the new intra-communicator created by the
+c                   MPI_Intercomm_merge in CLIM_Init (models)
+c                   or in inicmc via CLIM_Init (coupler Oasis)
+c
+c     lib mp:
+c     -------
+c        mpi-1 (or mpi-2)
+c
+c     author:
+c     -------
+c        Eric Sevault   - METEO FRANCE
+c        Laurent Terray - CERFACS
+c        Jean Latour    - F.S.E.   (mpi-2)
+c        Sophie Valcke  - CERFACS (08/09/00 -modified)
+c        Arnaud Caubel  - FECIT (08/02 - removed kmxtag as argument)
+c     ----------------------------------------------------------------
+      USE mod_kinds_model
+      USE mod_prism_proto
+      USE mod_comprism_proto
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) kinfo
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)    ip, info1, info, ilgdt, ipos, is,
+     *             itag1, isdmod, incp, ipotag,nsegid
+      INTEGER (kind=ip_intwp_p)    irempo, il_maxtag, il_start, il_end
+c
+      PARAMETER    (ibuflen=3)
+      INTEGER (kind=ip_intwp_p)    iposbuf, ibuff_mpi(ibuflen) 
+      INTEGER (kind=ip_intwp_p)    istatus(MPI_STATUS_SIZE), imaxbyt
+      LOGICAL      ll_flag
+      INTEGER (kind=ip_intwp_p), allocatable :: ireq(:)
+      INTEGER (kind=ip_intwp_p)              :: ireqrecv
+      INTEGER (kind=ip_intwp_p)              :: irc
+      INTEGER (kind=ip_intwp_p)              :: rpkwork(ig_CLIMmax)
+c     ----------------------------------------------------------------
+c
+c
+c     0. define some variables 
+c     ------------------------
+c
+      WRITE(nulprt,*)'Start - -  '
+c           
+      nexit  = 0
+      istatus(:)=0
+      ibuff_mpi(:)=0
+      call MPI_Attr_get(MPI_COMM_WORLD, MPI_TAG_UB, CLIM_MaxTag, 
+     $    ll_flag,info)
+      if(info.ne.MPI_SUCCESS) then
+        write(nulprt, * )'CLIM_Start_MPI -- MPI_Attr_get failed !',info
+        call MPI_ABORT (mpi_comm, 0, info)
+      endif
+      if ( .not. ll_flag ) then
+         write(nulprt, * ) 'Warning:  MPI_Attr_get did not return '
+         write(nulprt, * ) ' a valid CLIM_MaxTag!'
+         write(nulprt, * ) ' CLIM_MaxTag is set to 32767!'
+         CLIM_MaxTag = 32767
+      else
+         write(nulprt, * ) 'CLIM_MaxTag is now ', CLIM_MaxTag
+!
+!     limit CLIM_MaxTag to 2^^30 - 1 (J. Latour)
+!
+         if ( CLIM_MaxTag .gt. 1073741823 ) CLIM_MaxTag =  1073741823
+         write(nulprt, * ) 'CLIM_MaxTag is now ', CLIM_MaxTag
+!
+      endif
+      il_maxtag = CLIM_MaxTag - 1
+      itag1 = CLIM_MaxTag
+      ilgdt = CLIM_ParSize
+C
+c*    1. broadcast usefull informations
+c     ---------------------------------
+c
+      ibuff_mpi(1) = mynum 
+      ibuff_mpi(2) = modtid(mynum) 
+      ibuff_mpi(3) = nports
+c
+      WRITE(nulprt,FMT='(A,A)') 'Start- send- MODEL ',cmynam
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  num  :',mynum
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  tid  :',modtid(mynum)
+      WRITE(nulprt,FMT='(A,I9)')'Start- send-  nport:',nports
+c
+      iposbuf = 0
+      call MPI_Pack ( ibuff_mpi, ibuflen, MPI_INTEGER, pkwork,
+     *                ig_maxtype, iposbuf, mpi_comm, info )
+      call MPI_Pack ( cmynam, CLIM_Clength, MPI_CHARACTER, pkwork,
+     *                ig_maxtype, iposbuf, mpi_comm, info )
+      DO 210 ji=1,nports
+         call MPI_Pack ( cports(ji), CLIM_Clength, MPI_CHARACTER,
+     *           pkwork, ig_maxtype, iposbuf, mpi_comm, info )
+         call MPI_Pack ( myport(1,ji), 5, MPI_INTEGER, pkwork,
+     *                   ig_maxtype, iposbuf, mpi_comm, info )
+         call MPI_Pack ( mydist(1,ji), ilgdt, MPI_INTEGER, pkwork,
+     *                   ig_maxtype, iposbuf, mpi_comm, info )
+ 210   CONTINUE 
+c
+c*     In the direct case, Oasis process is not a process involved in the 
+c*     coupling
+c
+       IF (lg_oasis_field) THEN
+          il_start = 0
+          il_end = ncplprocs-1
+       ELSE
+          il_start = 1
+          il_end = ncplprocs
+       ENDIF
+       ALLOCATE(ireq(0:ncplprocs))
+       irc = 0
+      DO 220 ji = il_start, il_end
+c
+c       Send to all processors involved in the coupling except itself
+        IF ( ji .NE. mynum ) THEN
+            CALL MPI_Isend ( pkwork, iposbuf, MPI_PACKED, modtid(ji),
+     *                      itag1, mpi_comm, ireq(irc), info )
+            irc = irc+1
+c
+        ENDIF 
+ 220  CONTINUE
+
+      WRITE (nulprt,FMT='(A,I3,A,I8,A)') 
+     * 'Start - broadcast from mynum = ',mynum,' <MPI ',info,'>'
+c
+c*    3. get these infos from other models and check ports
+c     ----------------------------------------------------
+c
+      imaxbyt=0
+      ireqrecv = 0
+      DO 380 ip=1, ncplprocs-1
+c
+c Blocking receive (to comment if use of non-blocking receive)
+        CALL MPI_IRecv(rpkwork, ig_maxtype, MPI_PACKED, MPI_ANY_SOURCE,
+     *                 itag1, mpi_comm, ireqrecv, info1 )
+        CALL MPI_Wait ( ireqrecv, istatus, info )
+        CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, info )
+        IF ( info .NE. 0 ) THEN
+            kinfo = CLIM_Unpack
+            WRITE(nulprt,FMT='(A,I3,A)')
+     *                 'Import - pb unpack <mpi ',info,'>'
+            GO TO 1010
+        ENDIF
+c END of blocking receive
+c
+c       
+        iposbuf = 0
+        CALL MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, ibuff_mpi,
+     *                      ibuflen, MPI_INTEGER, mpi_comm, info )
+        IF ( info .NE. 0 ) THEN
+            kinfo = CLIM_Unpack
+            WRITE(nulprt,FMT='(A,I3,A)')
+     *                 'Import - pb unpack <mpi ',info,'>'
+            GO TO 1010
+        ENDIF
+c
+        isdmod         = ibuff_mpi(1)
+        modtid(isdmod) = ibuff_mpi(2)
+        irempo         = ibuff_mpi(3)
+c
+        call MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, cnames(isdmod),
+     *                   CLIM_Clength, MPI_CHARACTER, mpi_comm, info )
+        DO 310 ji=1,irempo
+          call MPI_Unpack ( rpkwork, ig_maxtype, iposbuf, clrport(ji),
+     *                   CLIM_Clength, MPI_CHARACTER, mpi_comm, info )
+          call MPI_Unpack( rpkwork, ig_maxtype, iposbuf, irport(1,ji), 
+     *                           5, MPI_INTEGER, mpi_comm, info )
+          call MPI_Unpack( rpkwork, ig_maxtype, iposbuf, irdist(1,ji),
+     *                           ilgdt, MPI_INTEGER, mpi_comm, info )
+ 310    CONTINUE
+c
+        WRITE (nulprt,FMT='(A,A)')  'Start - MODEL ',cnames(isdmod)
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   num  :',isdmod
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   tid  :',modtid(isdmod)
+        WRITE (nulprt,FMT='(A,I9)') 'Start -   nport:',irempo
+c
+        ncode(isdmod) = 0
+c
+        DO 350 ji=1,nports
+          DO 340 jj=1,irempo
+            IF (cports(ji).eq.clrport(jj).and.
+     *          myport(1,ji)+irport(1,jj).eq.1) THEN
+                IF ((mydist(CLIM_Strategy,ji).eq.CLIM_Serial.and.
+     *              myport(4,ji).lt.irport(4,jj)).or.
+     *              (irdist(CLIM_Strategy,jj).eq.CLIM_Serial.and.
+     *              irport(4,jj).lt.myport(4,ji))) THEN
+                    kinfo = CLIM_IncSize
+                    WRITE(nulprt,FMT='(A,A,A,I2,A,I2,A,I8,I8)')
+     *                  'Start - WARNING Incompatible sizes - field',
+     *                  cports(ji),'model ',mynum,' and model ',
+     *                  isdmod,': ',myport(4,ji),irport(4,jj)
+                ELSEIF (myport(2,ji).ne.irport(2,jj)) THEN
+                    kinfo = CLIM_BadType
+                    WRITE(nulprt,FMT='(A,A,A,I2,A,I2,A,I2,I2)')
+     *                  'Start - WARNING Incompatible types - field',
+     *                  cports(ji),'model ',mynum,' and model ',
+     *                  isdmod,': ',myport(2,ji),irport(2,jj)
+                ELSE
+                    IF (myport(1,ji).eq.CLIM_Out) THEN
+                        incp   = ig_ntime / ig_frqmin + 1
+                        ipotag = CLIM_MaxTag - (ji-1)*incp - 1
+                    ELSE
+                        incp   = ig_ntime / ig_frqmin + 1
+                        ipotag = CLIM_MaxTag - (jj-1)*incp - 1
+                    ENDIF
+                    IF ((ipotag-incp).lt.il_maxtag) THEN
+                        il_maxtag = ipotag - incp
+                    ENDIF
+                    IF (mydist(CLIM_Strategy,ji).ne.CLIM_Serial.and
+     *               .irdist(CLIM_Strategy,jj).ne.CLIM_Serial) THEN
+                        IF (mydist(CLIM_Strategy,ji).ne.
+     *                      irdist(CLIM_Strategy,jj)) THEN
+                           WRITE (nulprt,FMT=*)'STOP in Clim_Start_MPI'
+                           call flush (nulprt)
+                           call MPI_ABORT (mpi_comm, 0, info)
+                        ELSE
+                            IF (mydist(CLIM_Segments,ji).eq.
+     *                      irdist(CLIM_Segments,jj)) THEN
+                                nsegid = 0                            
+                                DO  is=1,2*mydist(CLIM_Segments,ji)
+                                  IF (mydist(CLIM_Segments+is,ji).eq.
+     *                               irdist(CLIM_Segments+is,jj)) THEN 
+                                      nsegid = nsegid + 1
+                                  ENDIF
+                                END DO
+                                IF (nsegid.eq.
+     *                              (2*mydist(CLIM_Segments,ji))) THEN
+                                    nlinks = nlinks + 1
+                                    ipos   = 5
+                                    myport(ipos,ji)=myport(ipos,ji)+ 1
+                                    myport(ipos+myport(ipos,ji),ji)
+     *                                     = nlinks
+                                    mylink(1,nlinks) = isdmod
+                                    mylink(2,nlinks) = modtid(isdmod)
+                                    mylink(3,nlinks) = ipotag
+                                    mylink(4,nlinks) = 1
+                                    mylink(5,nlinks) = 0
+                                    mylink(6,nlinks) = myport(4,ji)
+                                    WRITE(nulprt,FMT='(A,A)')
+     *                                  'Start - LINK ',cports(ji)
+                                    WRITE(nulprt,FMT='(A,I2,A,I1,A,I2,
+     *                                 A,I1,A,I10,A,I10)')
+     *                                  'Start - [model ',
+     *                                  mynum,'/io ',myport(1,ji),'] - 
+     *                                    [model ',
+     *                                  isdmod,'/io ',irport(1,jj),'] 
+     *                                   using tags ',
+     *                                  ipotag,' to ',ipotag-incp+1
+                                    call flush(nulprt)
+                                ENDIF    
+                            ENDIF
+                        ENDIF
+                    ELSE 
+                        nlinks = nlinks + 1
+                        ipos   = 5
+                        myport(ipos,ji) = myport(ipos,ji) + 1
+                        myport(ipos+myport(ipos,ji),ji) = nlinks
+                        mylink(1,nlinks) = isdmod
+                        mylink(2,nlinks) = modtid(isdmod)
+                        mylink(3,nlinks) = ipotag
+                        mylink(4,nlinks) = 1
+                        mylink(5,nlinks) = 0
+                        mylink(6,nlinks) = myport(4,ji)
+                        IF (mydist(CLIM_Strategy,ji).eq.CLIM_Serial.and
+     *                   .irdist(CLIM_Strategy,jj).ne.CLIM_Serial) THEN
+                            mylink(4,nlinks) = irdist(CLIM_Segments,jj)
+                            DO 330 is=1,2*irdist(CLIM_Segments,jj)
+                              mylink(4+is,nlinks) = irdist
+     *                                      (CLIM_Segments+is,jj)
+ 330                        CONTINUE
+                        ENDIF
+                        WRITE(nulprt,FMT='(A,A)')
+     *                      'Start - LINK ',cports(ji)
+                        WRITE(nulprt,FMT='(A,I2,A,I1,A,I2,A,
+     *                       I1,A,I10,A,I10)')
+     *                      'Start - [model ',
+     *                      mynum,'/io ',myport(1,ji),'] - [model ',
+     *                      isdmod,'/io ',irport(1,jj),'] using tags ',
+     *                      ipotag,' to ',ipotag-incp+1
+                        call flush(nulprt)
+                    ENDIF                    
+                ENDIF
+            ENDIF
+ 340      CONTINUE
+ 350    CONTINUE
+c
+        WRITE (nulprt,FMT='(A)') 'Start - -'
+ 380  CONTINUE
+c
+c     MPI_wait on the above MPI_Isend so to not change the content of pkwork
+c     before the sending is complete.
+      irc = 0
+      DO 420 ji = il_start, il_end
+        IF ( ji .NE. mynum ) THEN
+            CALL MPI_wait ( ireq(irc), istatus, info )
+            WRITE (nulprt, FMT='(A)') 'After MPI_wait'
+            irc = irc+1
+        ENDIF 
+ 420  CONTINUE
+      DEALLOCATE(ireq)
+c
+c*    correct execution
+c
+      nexit = 1
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      WRITE (nulprt,FMT='(A)') 'Returning from Start-mpi  -- '
+      CALL FLUSH(nulprt)
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_get_localcomm_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_get_localcomm_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_get_localcomm_proto.F	(revision 1677)
@@ -0,0 +1,34 @@
+       SUBROUTINE prism_get_localcomm_proto(il_local_comm, kinfo)
+c
+c*    *** Get_localcomm ***   PRISM 1.0
+c
+c     purpose:
+c     --------
+c        Each component get his local communicator.
+c
+c     interface:
+c     ----------
+c        ig_local_comm : local communicator
+c        kinfo  : exit status
+c
+c     lib mp:
+c     -------
+c        mpi-1 or mpi-2
+c
+c     author:
+c     -------
+c        Arnaud Caubel - Fecit (08/02 - created)
+c
+c     ----------------------------------------------------------------
+c
+      USE mod_kinds_model
+      USE mod_prism_proto 
+      USE mod_comprism_proto
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)	    il_local_comm, kinfo
+c     ----------------------------------------------------------------
+
+      il_local_comm = ig_local_comm
+      kinfo = CLIM_Ok
+
+      END
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_init_comp_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_init_comp_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_init_comp_proto.F	(revision 1677)
@@ -0,0 +1,754 @@
+       SUBROUTINE prism_init_comp_proto(il_mynummod, cdnam, kinfo)
+c
+c*    *** PRISM_init_comp ***   PRISM 1.0
+c
+c     purpose:
+c     --------
+c        start models
+c
+c     interface:
+c     ----------
+c        cdnam  : name of the calling model
+c        il_mynummod : model number
+c        kinfo  : exit status
+c
+c     lib mp:
+c     -------
+c        MPI-1 or MPI-2
+c
+c     author:
+c     -------
+c       Sophie Valcke  - CERFACS (08/09/00 -created from CLIM_Init)
+c       Jean Latour - F.S.E. - Version MPMD launch with mpi-1
+c                   - implies the use of mpiexec server process on VPPs     
+c                     or the command mpirun on most platforms
+c       Arnaud Caubel - FECIT (08/02 - created from CLIM_Init - removed 
+c                              some arguments and added dynamic allocation)
+c       S. Legutke - MPI M&D - cg_clim/def_rstfile initialized
+c     ----------------------------------------------------------------
+c
+      USE mod_kinds_model
+      USE mod_prism_proto
+      USE mod_comprism_proto
+#if !defined key_noIO
+      USE mod_psmile_io_interfaces
+#endif
+      IMPLICIT NONE
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      CHARACTER*(*) cdnam
+      INTEGER (kind=ip_intwp_p)	    kinfo
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)     mpi_status(MPI_STATUS_SIZE), 
+     $    il_mynummod      
+      INTEGER (kind=ip_intwp_p)     imodst, iost, ip, iprcou, iprmod
+      INTEGER (kind=ip_intwp_p)     il_err, il_rank, il_maxcplproc
+      INTEGER (kind=ip_intwp_p)     il_CLIM_Maxport, il_CLIM_MaxLink
+      INTEGER (kind=ip_intwp_p)     ji, jj, jl, ir, iremsize,ibuff, 
+     $    itagcol, il_size
+      INTEGER (kind=ip_intwp_p)     icolor, ikey, iposbuf, info
+      INTEGER (kind=ip_intwp_p)     il_start, il_end, il_logrank
+      INTEGER (kind=ip_intwp_p)     impi_newcomm2, impi_intercomp1,
+     $    jlocal
+      INTEGER (kind=ip_intwp_p)     imaxmodel, iarrb(2)
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: 
+     $    impi_intercomp 
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: 
+     $    impi_newcomm
+      LOGICAL       ll_file
+      PARAMETER     (itagcol=9876)
+      REAL (kind=ip_realwp_p) rl_testvar
+      REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: rl_work
+      CHARACTER(len=6) :: cl_comm, cl_argv
+      INTEGER(kind=ip_intwp_p), DIMENSION(1024) :: iarr_err
+      INTEGER(kind=ip_intwp_p) :: integer_byte_size, ii, io_size, 
+     $    integer_io_size, il_ibyt, il_int, il_char, il_log, il_rl_work
+      LOGICAL :: ll_log
+      CHARACTER*1 :: cl_char 
+c     ----------------------------------------------------------------
+c
+      rl_testvar = 0.0_ip_realwp_p
+c
+c*    1. get arguments and some Initilizations
+c     ----------------------------------------
+c
+      nexit = 0
+c
+      kinfo = CLIM_Ok
+c
+      cmynam=' '
+      cmynam=cdnam
+c
+      nports = 0
+      nlinks = 0
+      ig_nbpart = 0
+      nbsend = 0
+      nbrecv = 0
+      mpi_status(:)=0
+      iarrb(:)=0
+      ibuff = 0
+c     By default, the number of corners is 4. It will be changed if the
+c     model calls prism_write_corner.
+      ig_noc = 4
+c
+c*    2.0 Start global MPI environment for Oasis and models
+c     -----------------------------------------------------
+c
+      lg_mpiflag = .FALSE.
+      CALL MPI_Initialized ( lg_mpiflag, mpi_err )
+      IF ( .NOT. lg_mpiflag ) THEN
+          CALL MPI_INIT ( mpi_err )
+          WRITE (0,FMT='(A)') 'Calling MPI_Init in prism_init_comp...'
+      ELSE
+          WRITE (0,FMT='(A)') 'No call of MPI_Init in prism_init_comp.'
+      ENDIF
+c
+      CALL MPI_Comm_Size(MPI_COMM_WORLD,mpi_size,mpi_err)
+      CALL MPI_Comm_Rank(MPI_COMM_WORLD,mpi_rank,mpi_err)
+c     
+      WRITE (0, FMT='(A)')  'Init - CLIM 2.0 / MPI-1'
+      WRITE (0, FMT='(A,A)') 'Init - name of the model: ',
+     *     cdnam
+      WRITE(0,*)'Init - -  rank = ',mpi_rank,' in global comm'
+      WRITE(0,*)'Init - -  size = ',mpi_size,' of global comm'
+c
+c*    3.1 Case MPI-1 : Split global communicator into disjoint communicators
+c*                     local for each model
+c*    ----------------------------------------------------------------------
+c
+#ifdef use_comm_MPI1
+c     
+c*    MPI_COMM_WORLD is the global communicator for all processes
+c*    it includes Oasis and all model processes
+c*    It is duplicated in "mpi_comm" for compatibility with the
+c*    MPI-2 start option that implies multiple MPI_Comm_Spawn.
+c     
+         CALL MPI_COMM_DUP(MPI_COMM_WORLD,mpi_comm,mpi_err)
+         WRITE(0,*)'Init - - comm_dup done= ',mpi_comm
+
+c     
+c*    3.1.1 generates a "color" from the model name 
+c     
+         ALLOCATE (cunames(mpi_size), stat = il_err)
+         IF (il_err.NE.0) WRITE (0,*) 
+     $        'Init - Error in cunames allocation '
+         call MPI_Allgather(cmynam,CLIM_Clength,MPI_CHARACTER,
+     &        cunames,CLIM_Clength,MPI_CHARACTER,
+     &        mpi_comm,mpi_err)
+         icolor=1
+         do while ((trim(cmynam).ne.trim(cunames(icolor))).and.
+     &        (icolor.le.mpi_size))
+            icolor=icolor+1
+         enddo
+         IF (icolor.le.mpi_size) THEN
+            icolor=icolor*100
+         ELSE 
+          WRITE (0,*) 
+     $    'Init - - Could not find myself in the model namespace!'
+          WRITE (0,*) 'Init - - Check namcouple and '
+          WRITE (0,*) 'model name tags for consistency !'
+          call MPI_ABORT (mpi_comm, 0, mpi_err)
+         ENDIF
+         
+c     
+c*    3.1.2 split MPI_COMM_WORLD in local, disjoints, communicators
+c     
+         ikey = 1
+         call MPI_COMM_SPLIT(MPI_COMM_WORLD, icolor, ikey,
+     *        ig_local_comm, mpi_err)
+         IF(mpi_err .NE. MPI_SUCCESS) GOTO 215
+c     
+c*    3.1.3 get the model number from Oasis (proc 0 in global comm)
+c     
+         CALL MPI_Send(icolor,1,MPI_INTEGER,0,itagcol,mpi_comm, mpi_err)
+c     
+         CALL MPI_Recv(ibuff,1,MPI_INTEGER,0,itagcol,mpi_comm,
+     *        mpi_status, mpi_err)
+c
+         il_mynummod = ibuff
+         ig_mynummod = il_mynummod
+         nexit = 1
+         WRITE(0,*)'Init - model number : mynummod = ',il_mynummod
+c
+c*    3.2 Case MPI-2 
+c*    --------------
+c 
+#else
+c      
+         CALL MPI_Comm_get_parent(impi_intercomp1,mpi_err)
+         WRITE(0,*)'impi_intercomp1 ',impi_intercomp1
+         IF ( mpi_err .NE. MPI_SUCCESS ) THEN
+            WRITE(0,*)'Init_comp - - Error on Intercomm '
+            kinfo = CLIM_Mpi
+            GO TO 1010
+         ENDIF
+c     
+         CALL MPI_Comm_remote_size(impi_intercomp1,iremsize,mpi_err)
+c     
+         CALL MPI_Intercomm_merge(impi_intercomp1, .true., 
+     &        impi_newcomm2, mpi_err)
+         CALL MPI_Comm_size(impi_newcomm2, mpi_size, mpi_err)
+         CALL MPI_Comm_rank(impi_newcomm2, mpi_rank, mpi_err)
+c     
+         jlocal=2
+c     
+         STARTMOD : DO
+c     
+         IF (jlocal.eq.2) THEN
+            CALL MPI_BCAST(iarrb,2,MPI_INTEGER,0,
+     &           impi_newcomm2,ir)
+            jl=iarrb(1)
+            imaxmodel=iarrb(2)
+            ALLOCATE(impi_intercomp(imaxmodel))
+            ALLOCATE(impi_newcomm(imaxmodel + 1))
+            impi_intercomp(:)=0
+            impi_newcomm(:)=0
+            impi_intercomp(1) = impi_intercomp1 
+            impi_newcomm(2) = impi_newcomm2
+            if (jl .gt. imaxmodel ) EXIT STARTMOD 
+            cl_comm = 'obione'
+            cl_argv='      '
+            CALL MPI_COMM_SPAWN(cl_comm,cl_argv,1,MPI_INFO_NULL, 0,
+     &           impi_newcomm(jlocal), impi_intercomp(jlocal),
+     &           iarr_err, mpi_err)
+c     
+            CALL MPI_Intercomm_merge(impi_intercomp(jlocal), .false.,
+     &           impi_newcomm(jlocal+1), mpi_err)
+            jlocal=jlocal+1
+            CALL MPI_Comm_size(impi_newcomm(jlocal), mpi_size, mpi_err)
+            CALL MPI_Comm_rank(impi_newcomm(jlocal), mpi_rank, mpi_err)
+         ELSE
+            
+            CALL MPI_BCAST(iarrb,2,MPI_INTEGER,0,
+     &           impi_newcomm(jlocal),ir)
+            jl=iarrb(1)
+            imaxmodel=iarrb(2)
+            
+            if (jl .gt. imaxmodel ) EXIT STARTMOD
+c     
+            cl_comm = 'obione'
+            cl_argv='      '
+            CALL MPI_COMM_SPAWN(cl_comm,cl_argv,1,MPI_INFO_NULL, 0,
+     &           impi_newcomm(jlocal), impi_intercomp(jlocal), 
+     &           iarr_err, mpi_err)
+c     
+            CALL MPI_Intercomm_merge(impi_intercomp(jlocal), .false., 
+     &           impi_newcomm(jlocal+1), mpi_err)
+            jlocal=jlocal+1
+            CALL MPI_Comm_size(impi_newcomm(jlocal), mpi_size, mpi_err)
+            CALL MPI_Comm_rank(impi_newcomm(jlocal), mpi_rank, mpi_err)
+            WRITE(0,*)'Init_comp - -  rank = ',
+     $           mpi_rank,' in new comm'
+            WRITE(0,*)'Init_comp - -  size = ',
+     $           mpi_size,' of new comm'
+c     
+         ENDIF
+         END DO    STARTMOD
+c     
+         CALL MPI_COMM_DUP(impi_newcomm(jlocal),mpi_comm,mpi_err)
+         DO jl=2,jlocal
+            call MPI_COMM_FREE(impi_newcomm(jl),mpi_err)
+         ENDDO
+         ig_local_comm = MPI_COMM_WORLD
+         il_mynummod = imaxmodel - jlocal + 2
+         ig_mynummod = il_mynummod
+         nexit = 1
+         WRITE(0,*)'Init - model number : mynummod = ',il_mynummod
+         WRITE(0,*)'Init_comp - - Intercomm with Oasis = ',mpi_comm
+         DEALLOCATE(impi_intercomp)
+         DEALLOCATE(impi_newcomm)
+#endif
+c
+C*    4.0 Receive information from Oasis, allocate global arrays,
+c         initialize global variables and open logfile
+c      ------------------------------------------------------------------
+      CALL MPI_Recv(knmods, 1, MPI_INTEGER, 0, itagcol,
+     $    mpi_comm, mpi_status, mpi_err)
+      IF (mpi_ERR.ne.MPI_SUCCESS) THEN
+          WRITE(UNIT = 0,FMT = *)
+     $    'Init - Problem with reception of information from Oasis !'
+          WRITE(UNIT = 0,FMT = *)'STOP in PRISM_init_comp'
+          call flush(0)
+          call MPI_ABORT (mpi_comm, 0, mpi_err)
+      ENDIF
+      CALL MPI_Recv(ig_clim_nfield, 1, MPI_INTEGER, 0, itagcol+1,
+     $    mpi_comm, mpi_status, mpi_err)
+      IF (mpi_ERR.ne.MPI_SUCCESS) THEN
+          WRITE(UNIT = 0,FMT = *)
+     $    'Init - Problem with reception of information from Oasis !'
+          WRITE(UNIT = 0,FMT = *)'STOP in PRISM_init_comp'
+          call flush(0)
+          call MPI_ABORT (mpi_comm, 0, mpi_err)
+      ENDIF
+c
+      ALLOCATE(kbcplproc(knmods))
+      ALLOCATE(kbtotproc(knmods))
+      ALLOCATE(iga_unitmod(knmods))
+      ALLOCATE(cg_modnam(knmods))
+c
+      integer_byte_size = BIT_SIZE(ii)/8
+      INQUIRE (iolength=io_size) ii
+      integer_io_size = io_size
+      il_int = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) rl_testvar
+      il_ibyt = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) cl_char
+      il_char = io_size/integer_io_size*integer_byte_size
+      INQUIRE (iolength=io_size) ll_log
+      il_log = io_size/integer_io_size*integer_byte_size
+      il_rl_work = (29 + 64*ig_clim_nfield) * (il_char/il_ibyt + 1) + 
+     $    (9 + 3*knmods + 9*ig_clim_nfield) * (il_int/il_ibyt + 1) +
+     $    3 * (il_log/il_ibyt + 1)
+      ALLOCATE (rl_work(il_rl_work), stat=il_err)
+c
+      kbcplproc(:)=0
+      kbtotproc(:)=0
+      rl_work(:)=0
+      il_size = il_rl_work * il_ibyt
+      il_CLIM_Maxport = ig_clim_nfield *2
+c
+      ALLOCATE (cg_cnaminp(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in cg_cnaminp allocation in PRISM_init_comp routine!'
+      cg_cnaminp(:)=' '
+      ALLOCATE (cg_cnamout(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in cg_cnamout allocation in PRISM_init_comp routine!'
+      cg_cnamout(:)=' '
+      ALLOCATE (ig_clim_lag(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in ig_clim_lag allocation in PRISM_init_comp routine!'
+      ig_clim_lag(:)=0
+      ALLOCATE (ig_clim_reverse(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $   'Error ig_clim_reverse allocation in PRISM_init_comp routine!'
+      ig_clim_reverse(:)=0
+      ALLOCATE (ig_clim_invert(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error ig_clim_invert allocation in PRISM_init_comp routine!'
+      ig_clim_invert(:)=0
+      ALLOCATE (ig_def_lag(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in ig_def_lag allocation in PRISM_init_comp routine!'
+      ig_def_lag(:)=0
+      ALLOCATE (ig_def_reverse(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error ig_def_reverse allocation in PRISM_init_comp routine!'
+      ig_def_reverse(:)=0
+      ALLOCATE (ig_def_invert(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error ig_def_invert allocation in PRISM_init_comp routine!'
+      ig_def_invert(:)=0
+      ALLOCATE (ig_clim_freq(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $   'Error in ig_clim_freq allocation in PRISM_init_comp routine!'
+      ig_clim_freq(:)=0
+      ALLOCATE (ig_def_freq(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in ig_def_freq allocation in PRISM_init_comp routine!'
+      ig_def_freq (:) = 0
+      ALLOCATE (ig_clim_seq(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in ig_clim_seq allocation in PRISM_init_comp routine!'
+      ig_clim_seq(:)=0
+      ALLOCATE (ig_def_seq(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $    'Error in ig_def_seq allocation in PRISM_init_comp routine!'
+      ig_def_seq(:)=0
+      ALLOCATE (cg_clim_rstfile(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $'Error in cg_clim_rstfile allocation in PRISM_init_comp routine!'
+      cg_clim_rstfile(:)=' '
+      ALLOCATE (cg_def_rstfile(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in cg_def_rstfile allocation in PRISM_init_comp routine!'
+      cg_def_rstfile(:)=' '
+      ALLOCATE (ig_clim_norstfile(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_clim_norstfile alloc in PRISM_init_comp routine!'
+      ig_clim_norstfile(:)=0
+      ALLOCATE (ig_def_norstfile(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_def_norstfile alloc in PRISM_init_comp routine!'
+      ig_def_norstfile(:)=0
+      ALLOCATE (ig_clim_state(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_clim_state allocation in PRISM_init_comp routine!'
+      ig_clim_state(:)=0
+      ALLOCATE (ig_def_state(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_def_state allocation in PRISM_init_comp routine!'
+      ig_def_state(:)=0
+      ALLOCATE (ig_clim_trans(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_clim_trans allocation in PRISM_init_comp routine!'
+      ig_clim_trans(:)=0
+      ALLOCATE (ig_clim_numlab(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_clim_numlab allocation in PRISM_init_comp routine!'
+      ig_clim_numlab(:)=0
+      ALLOCATE (ig_def_trans(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_def_trans allocation in PRISM_init_comp routine!'
+      ig_def_trans(:)=0
+      ALLOCATE (cg_clim_inpfile(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_clim_inpfile allocation in PRISM_init_comp routine!'
+      cg_clim_inpfile(:)=' '
+      ALLOCATE (cg_def_inpfile(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_def_inpfile allocation in PRISM_init_comp routine!'
+      cg_def_inpfile(:)=' '
+      ALLOCATE (cg_ignout_field(il_CLIM_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in cd_ignout_field allocation in PRISM_init_comp routine!'
+      cg_ignout_field(:)=' ' 
+      ALLOCATE (ig_def_numlab(il_clim_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in ig_def_numlab allocation in PRISM_init_comp routine!'
+      ig_def_numlab(:)=0
+      ALLOCATE (cga_clim_locatorbf(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in cga_clim_locatorbf allocation in PRISM_init_comp!'
+      cga_clim_locatorbf(:)='    '
+      ALLOCATE (cga_clim_locatoraf(ig_clim_nfield), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in cga_clim_locatoraf allocation in PRISM_init_comp!'
+      cga_clim_locatoraf(:)='    '
+      ALLOCATE (cga_clim_locator(il_clim_Maxport), stat=il_err)
+      IF (il_err.ne.0) WRITE(0,*)
+     $ 'Error in cga_clim_locator allocation in PRISM_init_comp!'
+      cga_clim_locator(:)='    '
+c
+      CALL MPI_Recv ( rl_work, il_size, MPI_PACKED, 0,
+     $     itagcol+2, mpi_comm, mpi_status, mpi_err )
+c
+      iposbuf = 0
+      call MPI_Unpack (rl_work, il_size, iposbuf, cgroup, 8,
+     $    MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_ntime, 1,
+     $    MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf,kbcplproc, knmods,
+     $    MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, kbtotproc, knmods,
+     $    MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, iga_unitmod, knmods,
+     $    MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_frqmin, 1,
+     $    MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_cnaminp, 
+     $    8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_cnamout, 
+     $    8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_lag, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_reverse, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_invert, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_freq, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_seq, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_rstfile, 
+     $    8*ig_clim_nfield,MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_norstfile, 
+     $    ig_clim_nfield,MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_nbr_rstfile, 1, 
+     $     MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, lg_ncdfrst, 1, 
+     $     MPI_LOGICAL, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, lg_oasis_field, 1, 
+     $     MPI_LOGICAL, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_state, 
+     $     ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_trans, 
+     $     ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_inpfile, 
+     $     32*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_inidate, 
+     $     6, MPI_INTEGER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, ig_clim_numlab, 
+     $     ig_clim_nfield, MPI_INTEGER, mpi_comm, info)
+CSV>>
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_cgrdnam, 
+     $    5, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_lonsuf, 
+     $    4, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cg_clim_latsuf, 
+     $    4, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, crn_clim_lonsuf, 
+     $    4, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, crn_clim_latsuf, 
+     $    4, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cga_clim_locatorbf, 
+     $    4*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, cga_clim_locatoraf, 
+     $    4*ig_clim_nfield, MPI_CHARACTER, mpi_comm, info)
+      call MPI_Unpack (rl_work, il_size, iposbuf, lg_clim_bsend, 1, 
+     $     MPI_LOGICAL, mpi_comm, info)
+CSV<< 
+      il_maxcplproc = 1
+      DO ji = 1, knmods
+        IF (il_maxcplproc.lt.kbcplproc(ji)) 
+     $      il_maxcplproc = kbcplproc(ji)
+      END DO
+      ig_CLIMmax = 3 + CLIM_Clength + il_CLIM_Maxport * 
+     $    (CLIM_Clength + 5 + CLIM_ParSize)
+c     
+c*    open trace file 
+c     ---------------
+c     
+      iost = 0
+      nulprt = iga_unitmod(il_mynummod)
+      INQUIRE (nulprt,OPENED = ll_file)
+      DO WHILE (ll_file)
+         nulprt = nulprt + 1 
+         INQUIRE (nulprt,OPENED = ll_file)
+      END DO
+#ifdef use_comm_MPI1
+      CALL MPI_Comm_Rank(ig_local_comm, il_logrank, mpi_err)
+#else
+      CALL MPI_Comm_Rank(MPI_COMM_WORLD, il_logrank, mpi_err)
+#endif
+      IF(il_logrank .le. 9) THEN
+         WRITE(cnaprt, FMT='(A,''.prt'',I1)') cdnam, il_logrank 
+      ELSE IF (il_logrank .le. 99) THEN
+         WRITE(cnaprt, FMT='(A,''.prt'',I2)') cdnam, il_logrank 
+      ELSE IF (il_logrank .le. 999) THEN
+         WRITE(cnaprt, FMT='(A,''.prt'',I3)') cdnam, il_logrank 
+      ELSE IF (il_logrank .le. 9999) THEN
+         WRITE(cnaprt, FMT='(A,''.prt'',I4)') cdnam, il_logrank
+      ELSE IF (il_logrank .gt. 99999) THEN
+         WRITE(0, *)'Cannot create the name of the trace file'
+         WRITE(0, *)'if more than 99999 processes for the model'
+         CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+      ENDIF
+      OPEN (UNIT=nulprt, FILE=cnaprt, STATUS='UNKNOWN',
+     *     FORM='FORMATTED', ERR=110, IOSTAT=iost)
+      WRITE(nulprt, *)'ig_clim_numlab', ig_clim_numlab(:)
+c     
+ 110  CONTINUE
+      IF (iost.ne.0) THEN
+         WRITE(0,*) 'ABORT in Init - unable to open trace file ',
+     *        iost
+         WRITE(0,*) nulprt, ' ', cnaprt
+         CALL MPI_ABORT (mpi_comm, 0, mpi_err)
+      ENDIF
+      WRITE(nulprt,*)'iga_unitmod, nulprt', 
+     $    iga_unitmod(il_mynummod), nulprt
+
+C
+C*    4.1 Define ncplprocs, the total number of processes involved
+C*    in the coupling, initialize il_CLIM_MaxLink and allocate "modtid"
+C     -----------------------------------------------------------------
+c
+c     For oasis monoprocessor and involved in the coupling : ncplprocs = 1
+      IF (lg_oasis_field) THEN
+         ncplprocs=1
+      ELSE
+         ncplprocs=0
+      ENDIF
+      DO 3 ji = 1, knmods
+        ncplprocs = ncplprocs + kbcplproc(ji)
+ 3    CONTINUE 
+      WRITE(nulprt,*)'Init - - ncplprocs = ', ncplprocs
+      IF (lg_oasis_field) THEN
+         il_start = 0
+         il_end = ncplprocs-1
+      ELSE
+         il_start = 1
+         il_end = ncplprocs
+      ENDIF
+      il_CLIM_MaxLink = ncplprocs * il_CLIM_Maxport
+
+      ALLOCATE (modtid(il_start:il_end), stat=il_err)
+      IF (il_err.ne.0) WRITE(nulprt,*)
+     $    'Error in modtid allocation in PRISM_init_comp routine!'
+      modtid(:)=0
+
+      DO 10 ip = il_start, il_end
+        modtid(ip) = -1
+ 10   CONTINUE
+
+
+C*    4.2 Define modtid, the vector giving, for each process involved
+C*    in the coupling,  its number in mpi_com (i.e in all model 
+C*    processes involved OR NOT in the coupling) 
+C     -----------------------------------------------------------
+c
+c     For coupler
+      iprcou = 0
+      imodst = 0
+      IF (lg_oasis_field) modtid(0) = 0
+c     For models
+      DO 5 ji = 1, knmods
+        IF (ji .eq. 1) THEN
+           imodst = 1
+        ELSE
+           imodst = imodst + kbtotproc(ji-1)
+        ENDIF
+        iprmod = 0
+        DO 7 jj = 1, kbcplproc(ji)
+          iprcou = iprcou + 1
+          iprmod = iprmod + 1
+          modtid(iprcou) = imodst + iprmod - 1
+ 7      CONTINUE
+ 5    CONTINUE
+c
+C     4.3 Allocate and initialize arrays defined in mod_comprism MODULE
+c     --------------------------------------------------------------
+
+
+      CALL MPI_Comm_Rank(mpi_comm,il_rank,mpi_err)      
+c
+      DO ji = 1, il_end
+        IF (il_rank.eq.modtid(ji)) THEN
+            ALLOCATE (ncode(il_start:il_end), stat=il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in ncode allocation in PRISM_init_comp routine!'
+            ncode(:)=0
+            ALLOCATE (delta(il_start:il_end), stat=il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in delta allocation in PRISM_init_comp routine!'
+            delta(:)=0
+            ALLOCATE (delte(il_start:il_end), stat=il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in delte allocation in PRISM_init_comp routine!'
+            delte(:)=0
+            ALLOCATE (cnames(il_start:il_end), stat=il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $         'Error in cnames allocation in PRISM_init_comp routine!'
+            cnames(:)=' '
+            ALLOCATE (myport(5+il_maxcplproc,il_CLIM_Maxport), 
+     $          stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in myport allocation in PRISM_init_comp!'
+            myport(:,:)=0
+            ALLOCATE (mydist(CLIM_ParSize, il_CLIM_Maxport), 
+     $          stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in mydist allocation in PRISM_init_comp!'
+            mydist(:,:)=0
+            ALLOCATE (cports(il_CLIM_Maxport), stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in cports allocation in PRISM_init_comp!'
+            cports(:)=' '
+            ALLOCATE(clrport(il_CLIM_Maxport), stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          'Error in clrport allocation in PRISM_init_comp!'
+            clrport(:)=' '
+            ALLOCATE(irdist(CLIM_ParSize, il_CLIM_Maxport), 
+     $          stat = il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in irdist allocation in PRISM_init_comp'
+            irdist(:,:)=0
+            ALLOCATE(irport(5,il_CLIM_Maxport ), stat = il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in irport allocation in PRISM_init_comp'
+            irport(:,:)=0
+            ALLOCATE (mylink(4+CLIM_ParSize, il_CLIM_MaxLink), 
+     $          stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in mylink allocation in PRISM_init_comp!'
+            mylink(:,:)=0
+            ALLOCATE (pkwork(ig_CLIMmax), stat = il_err)
+            IF (il_err.ne.0) WRITE(nulprt,*)
+     $          'Error in pkwork allocation in PRISM_init_comp'
+            pkwork(:)=0
+            ALLOCATE (ig_def_part(CLIM_ParSize, ig_clim_nfield), 
+     $          stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $        ' Problem in ig_def_part allocation in PRISM_init_comp!'
+            ig_def_part(:,:)=0
+            ALLOCATE (ig_length_part(ig_clim_nfield), stat = il_err)
+            IF (il_err.ne.CLIM_Ok) WRITE(nulprt,*)
+     $         ' Problem in ig_def_part allocation in PRISM_init_comp!'
+            ig_length_part(:)=0
+c
+            DO ip = il_start, il_end
+              cnames(ip) = ' '
+            ENDDO
+        ENDIF
+      END DO
+c
+c
+C*    4.4 Define mynum, the number of the actual processor 
+c     in all processors involved in the coupling 
+c     If actual process is NOT involved in the coupling
+c     it will NOT call CLIM_Start
+C     -----------------------------------------------------------
+c
+      CALL MPI_Comm_Size(ig_local_comm, mpi_size, mpi_err)
+      CALL MPI_Comm_Rank(ig_local_comm, mpi_rank, mpi_err)
+c
+c     For model with il_mynummod=1, imodst=1
+      imodst = 1
+      IF (il_mynummod .gt. 1) then
+          DO 8 ji = 2, il_mynummod
+            imodst = imodst +  kbcplproc(ji-1)
+            WRITE(nulprt,*)'imodst :',imodst
+ 8        CONTINUE
+      ENDIF
+c
+      mynum = imodst + mpi_rank      
+C
+      WRITE(nulprt,*)'Init - - mynummod = ', il_mynummod
+      WRITE(nulprt,*)'Init - - mynum = ', mynum
+      WRITE(nulprt,*)'Init - - modtid() = ', modtid
+
+      DEALLOCATE(rl_work)
+
+      cg_modnam(il_mynummod) = cdnam
+
+#if !defined key_noIO
+      call psmile_io_init_comp(il_err)
+#endif
+cvg>>>
+C*    4.5 Initialization of grids writing
+C     -----------------------------------
+c
+c-- Receive flag 'grids_start' stating whether or not grids writing is needed
+c
+      WRITE (nulprt,*) 'Recv - grids_start'
+      CALL MPI_Recv (grids_start, 1, MPI_INTEGER, 0, itagcol+3,
+     $     mpi_comm, mpi_status, mpi_err)
+      IF (mpi_err == MPI_SUCCESS) THEN 
+         WRITE(nulprt,*) 'Recv - <from:0> <comm:',mpi_comm,'> <len:1>
+     $        <type:',MPI_INTEGER,'> <tag:',itagcol,'+3> ::  ',
+     $        grids_start
+         CALL FLUSH(nulprt)
+      ELSE
+         WRITE (nulprt,*) ' '
+         WRITE (nulprt,*) 'prism_init_comp: an error occured'
+         WRITE (nulprt,*) 'prism_init_comp: err= ', mpi_err 
+         WRITE (nulprt,*) 'prism_init_comp: STOP'
+         call MPI_ABORT (mpi_comm, 0, mpi_err)
+      ENDIF
+cvg<<<
+
+c 
+C*    5. Normal EXIT
+C
+ 1010 CONTINUE
+      
+      WRITE (nulprt,FMT='(A)') 'Init - -'
+      CALL FLUSH(nulprt)
+      RETURN
+C
+C*    6. Error STOP
+C
+ 215  CONTINUE
+      WRITE (UNIT = nulprt,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulprt,FMT = *)
+     $    ' Problem with MPI_Comm_Split function !!! '
+      WRITE (UNIT = nulprt,FMT = *) ' Mpi error code = ',mpi_err
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) ' '
+      WRITE (UNIT = nulprt,FMT = *) 'STOP in PRISM_init_comp'
+      call MPI_ABORT (mpi_comm, 0, mpi_err)
+C
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_put_inquire_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_put_inquire_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_put_inquire_proto.F90	(revision 1677)
@@ -0,0 +1,152 @@
+  SUBROUTINE prism_put_inquire_proto(id_port_id,kstep,kinfo)
+!
+!*    *** PRISM_put_inquire ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Sophie Valcke (08/03 - created from prism_put_proto)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)       kstep, kinfo, id_port_id
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)    il_newtime
+    INTEGER (kind=ip_intwp_p)	 iport
+!     ----------------------------------------------------------------
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    iport = -1
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0.or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN 
+       GOTO 1010
+    ENDIF
+!
+!
+!     if a field exported at a certain time should match an import
+!     at a time+lag, add the lag here; the lag is given by the user
+!     in the namcouple at the end of the field 2nd line.
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+       il_newtime = kstep + ig_def_lag(iport)
+    ENDIF
+    IF (iport.lt.0) THEN
+       WRITE(nulprt,FMT='(A,A)') &
+            'Put - WARNING - Invalid port out: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!   If the user indicated in the namcouple that the field must be
+!   accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
+!   end of the field 2nd line), do the local transformations.
+!
+    IF (ig_def_trans(iport) .eq. ip_average .or. &
+       ig_def_trans(iport) .EQ. ip_accumul .OR. &
+       ig_def_trans(iport) .EQ. ip_min .OR. &
+       ig_def_trans(iport) .EQ. ip_max) THEN
+        kinfo = PRISM_LocTrans
+    ENDIF
+!
+!*    Test if field must be written to restart file i.e.
+!*    - current time is time at the end of simulation +
+!*    - lag of current field is greater than 0
+!
+    IF (il_newtime.EQ.ig_ntime.AND.ig_def_lag(iport).GT.0) THEN
+!ac
+       IF (ig_def_state(iport) .NE. ip_output) THEN
+!ac
+!
+!*       Note: A model can have several restart files but same restart 
+!*       file can't be used by different models
+!
+       kinfo = PRISM_ToRest
+!ac
+   ENDIF
+!ac
+!    Test if the current time is a coupling (or I/O) time  
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+!ac
+          IF (ig_def_state(iport) .EQ. ip_output ) THEN
+              	kinfo = PRISM_Output
+          ELSE IF (ig_def_state(iport) .EQ. ip_expout .OR. ig_def_state(iport) .EQ. ip_ignout) THEN
+              kinfo = PRISM_ToRestOut
+          ENDIF	
+!ac
+#endif
+      ENDIF
+  ELSE
+!    Test if the current time is a coupling (or I/O) time
+       IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
+!
+#if !defined key_noIO
+!*   If the user indicated in the namcouple that the field is
+!*   a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
+!*   at the end of the field 1st line), do the writing to file here, e.g.:
+          IF (ig_def_state(iport) .EQ. ip_output .OR. &
+             ig_def_state(iport) .EQ. ip_expout .OR. &
+             ig_def_state(iport) .EQ. ip_ignout) THEN
+              kinfo = PRISM_Output
+          ENDIF
+#endif
+!*
+!*   If the user indicated in the namcouple that the field is
+!*   a coupling field (keyword EXPORTED','EXPOUT','IGNORED', 'IGNOUT' 
+!*   or 'AUXILARY' at the end of the field 1st line),do the export here.
+!*
+          IF (ig_def_state(iport) .EQ. ip_expout .OR. &
+               ig_def_state(iport) .eq. ip_exported .or. &
+               ig_def_state(iport) .eq. ip_ignored .or. &
+               ig_def_state(iport) .eq. ip_ignout .or. &
+               ig_def_state(iport) .eq. ip_auxilary) THEN
+
+              IF (kinfo .EQ. PRISM_Output) THEN
+                  kinfo = PRISM_SentOut
+              ELSE
+                  kinfo = PRISM_Sent
+              ENDIF
+
+          ENDIF
+      ENDIF
+  ENDIF	
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+    RETURN
+  END SUBROUTINE prism_put_inquire_proto
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_put_restart_proto.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_put_restart_proto.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_put_restart_proto.F90	(revision 1677)
@@ -0,0 +1,90 @@
+  SUBROUTINE prism_put_restart_proto (id_port_id, kstep, kinfo)
+!
+!*    *** PRISM_put ***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        write buffered field corresponding to port id_port_id in its 
+!        restart coupling file
+!
+!     interface:
+!     ----------
+!        id_port_id : port number of the field
+!	 kstep	: current time in seconds
+!	 kinfo	: output status
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!         Sophie Valcke (07/03 - created from prism_put_proto)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)      kstep, kinfo, id_port_id
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p)	   iport
+!     ----------------------------------------------------------------
+!
+!*    0. First check
+!     --------------
+!
+    IF (nexit.ne.1) THEN
+       kinfo = CLIM_FastExit
+       WRITE(nulprt,FMT='(A)') 'Put_restart - should not be called'
+       GO TO 1010
+    ENDIF
+    kinfo = PRISM_Ok
+!
+!*    1. check for this port in my list
+!     ---------------------------------
+!
+    iport = -1
+!
+!   Test if the field is defined in the namcouple and if its coupling period
+!   is not greater than the time of the simulation.
+    IF (ig_def_freq(id_port_id) .eq. 0.or. &
+         ig_def_freq(id_port_id) .gt. ig_ntime) THEN 
+       GOTO 1010
+    ENDIF
+!
+    IF (myport(1,id_port_id).eq.CLIM_Out) THEN
+       iport=id_port_id
+    ENDIF
+    IF (iport.lt.0) THEN
+       kinfo = CLIM_BadPort
+       WRITE(nulprt,FMT='(A,A)') &
+            'Put - WARNING - Invalid port out: ', &
+            cports(id_port_id)
+       GO TO 1010
+    ENDIF
+!
+!*  Field is written to restart file 
+    IF (lg_dgfield) THEN
+        IF (mydist(CLIM_Strategy,iport) .EQ. CLIM_Serial) THEN
+            CALL write_filer8(dg_field_trans(:,iport),cports(iport),iport)
+        ELSE
+            CALL write_file_parar8(dg_field_trans(:,iport),cports(iport),iport)
+        ENDIF
+    ELSE
+        IF (mydist(CLIM_Strategy,iport) .EQ. CLIM_Serial) THEN
+            CALL write_filer8(rg_field_trans(:,iport),cports(iport),iport)
+        ELSE
+            CALL write_file_parar8(rg_field_trans(:,iport),cports(iport),iport)
+        ENDIF
+    ENDIF
+    kinfo = PRISM_ToRest
+!
+!     ----------------------------------------------------------------
+!
+1010 CONTINUE
+    CALL FLUSH(nulprt)
+!
+  END SUBROUTINE prism_put_restart_proto
+
Index: CPL/oasis3/trunk/src/lib/psmile/src/prism_terminate_proto.F
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/prism_terminate_proto.F	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/prism_terminate_proto.F	(revision 1677)
@@ -0,0 +1,240 @@
+      SUBROUTINE prism_terminate_proto(kinfo)
+c
+c*    *** PRISM_Terminate ***   PRISM 1.0
+c
+c     purpose:
+c     --------
+c        leave mpi
+c
+c     interface:
+c     ----------
+c	 kinfo	: output status
+c
+c     lib mp:
+c     -------
+c        MPI-1 or MPI-2
+c
+c     author:
+c     -------
+c         Arnaud Caubel  - Fecit (08/02 - created from CLIM_Quit)
+c         S. Legutke     - MPI M&D, MPI_Finalize info added
+c     ----------------------------------------------------------------
+      USE mod_kinds_model      
+      USE mod_prism_proto
+      USE mod_comprism_proto
+#if !defined key_noIO
+      USE mod_psmile_io_interfaces
+#endif
+#include <mpif.h>
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)	kinfo
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p) info, il_rank, ji, il_start
+c     ----------------------------------------------------------------
+      INTEGER (kind=ip_intwp_p)       il_bufsizebyt
+      REAL(kind=ip_double_p)  dl_bufaddr
+c
+c*    0. First Check
+c     --------------
+c
+      IF (nexit.ne.1) THEN
+          kinfo = CLIM_FastExit
+          WRITE(nulprt,FMT='(A)') 'Terminate - should not be called'
+          GO TO 1010
+      ENDIF
+      WRITE(nulprt,*)'entering PRISM_terminate'
+      kinfo = CLIM_Ok
+c
+      CALL MPI_Comm_Rank(mpi_comm,il_rank,mpi_err)
+c
+      DEALLOCATE(kbtotproc)
+      DEALLOCATE(kbcplproc)
+      DEALLOCATE(iga_unitmod)
+      DEALLOCATE(cg_modnam)
+      DEALLOCATE(cunames)
+c
+      IF (lg_oasis_field) THEN
+         il_start = 0
+      ELSE
+         il_start = 1
+      ENDIF
+      DO ji = il_start, ncplprocs-1 
+        IF (il_rank.eq.modtid(ji)) THEN
+#if !defined key_noIO
+           call psmile_close_files(il_err)
+           call psmile_io_cleanup(il_err)
+#endif
+            DEALLOCATE (ncode, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $      'Error in ncode deallocation in prism_terminate'
+            DEALLOCATE (delta, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $          'Error in delta deallocation in prism_terminate'
+            DEALLOCATE (delte, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $          'Error in delte deallocation in prism_terminate'
+            DEALLOCATE (cnames, stat=il_err)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $          'Error in cnames deallocation in prism_terminate'
+            DEALLOCATE (myport, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in "myport" deallocation in prism_terminate'
+            DEALLOCATE (mydist,stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in "mydist" deallocation in prism_terminate'
+            DEALLOCATE (cports, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in "cports" deallocation in prism_terminate'
+            DEALLOCATE(clrport, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          'Error in clrport deallocation in prism_terminate'
+            DEALLOCATE(irdist, stat = il_ERR)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $          'Error in irdist deallocation in PRISM_terminate'
+            DEALLOCATE(irport, stat = il_ERR)
+            IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $          'Error in irport deallocation in PRISM_terminate'
+            DEALLOCATE (mylink, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in "mylink" deallocation in prism_terminate'
+            DEALLOCATE (pkwork, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $          ' Problem in "pkwork" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_part, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "ig_def_part" deallocation in prism_terminate'
+            DEALLOCATE (ig_length_part, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "ig_length_part" deallocation in prism_terminate'
+            DEALLOCATE (pkwork_field, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "pkwork_field" deallocation in prism_terminate'
+            DEALLOCATE (cg_cnaminp, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "cg_cnaminp" deallocation in prism_terminate'
+            DEALLOCATE (cg_cnamout, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $       ' Problem in "cg_cnamout" deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_lag, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "ig_clim_lag" deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_reverse, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem ig_clim_reverse deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_invert, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem ig_clim_invert deallocation in prism_terminate'
+            DEALLOCATE (ig_def_lag, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $       ' Problem in "ig_def_lag" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_reverse, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $       ' Problem ig_def_reverse deallocation in prism_terminate'
+            DEALLOCATE (ig_def_invert, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $       ' Problem ig_def_invert deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_freq, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $     ' Problem in "ig_clim_freq" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_freq, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "ig_def_freq" deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_seq, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "ig_clim_seq" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_seq, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $      ' Problem in "ig_def_seq" deallocation in prism_terminate'
+            DEALLOCATE (cg_clim_rstfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "cg_clim_rstfile" deallocation in prism_terminate'
+            DEALLOCATE (cg_def_rstfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "cg_def_rstfile" deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_norstfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $' Problem in "ig_clim_norstfile" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_norstfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $' Problem in "ig_def_norstfile" deallocation in prism_terminate'
+            DEALLOCATE (ig_clim_state, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "ig_clim_state" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_state, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $    ' Problem in "ig_def_state" deallocation in prism_terminate'
+             DEALLOCATE (ig_clim_trans, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "ig_clim_trans" deallocation in prism_terminate'
+             DEALLOCATE (ig_clim_numlab, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "ig_clim_numlab" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_trans, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $     ' Problem in "ig_def_trans" deallocation in prism_terminate'
+            DEALLOCATE (rg_field_trans, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "rg_field_trans" deallocation in prism_terminate'
+            DEALLOCATE (dg_field_trans, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $   ' Problem in "dg_field_trans" deallocation in prism_terminate'
+            DEALLOCATE (ig_number, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $        ' Problem in "ig_number" deallocation in prism_terminate'
+            DEALLOCATE (cg_clim_inpfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "cg_clim_inpfile" deallocation in prism_terminate'
+            DEALLOCATE (cg_def_inpfile, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "cg_def_inpfile" deallocation in prism_terminate'
+            DEALLOCATE (cg_ignout_field, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "cg_ignout_field" deallocation in prism_terminate'
+            DEALLOCATE (ig_def_numlab, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "ig_def_numlab" deallocation in prism_terminate'
+            DEALLOCATE (cga_clim_locatorbf, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem cga_clim_locatorbf deallocation in prism_terminate'
+            DEALLOCATE (cga_clim_locatoraf, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem cga_clim_locatoraf deallocation in prism_terminate'
+            DEALLOCATE (cga_clim_locator, stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem cga_clim_locator deallocation in prism_terminate'
+            IF (allocated(ig_aux)) DEALLOCATE(ig_aux,stat = il_ERR)
+            IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "ig_aux" deallocation in prism_terminate'
+            IF (lg_clim_bsend) THEN
+                CALL MPI_Buffer_Detach(dl_bufaddr, il_bufsizebyt, 
+     $              mpi_err)
+                DEALLOCATE (dg_bufsend, stat = il_ERR)
+                IF (il_ERR.ne.CLIM_Ok) WRITE(nulprt,*)
+     $  ' Problem in "dg_bufsend" deallocation in prism_terminate'
+            ENDIF
+        ENDIF
+      END DO
+      DEALLOCATE (modtid, stat=il_err)
+      IF (il_ERR.ne.0) WRITE(nulprt,*)
+     $    'Error in modtid deallocation in prism_terminate'
+      WRITE(nulprt, *) 'lg_mpiflag=', lg_mpiflag
+c
+      info = 0.0    
+      IF (.NOT. lg_mpiflag ) THEN
+          WRITE(nulprt,FMT='(A)') 
+     $    'Calling MPI_Finalize in prism_terminate ...'
+          CALL MPI_Finalize ( info )
+      ELSE
+          WRITE(nulprt,FMT='(A)') 
+     $    'No call of MPI_Finalize in prism_terminate.'
+      ENDIF      
+c
+      WRITE(nulprt,FMT='(A,I3,A)')
+     *     'Quit - exit status <mpi ',info,'>'
+c
+c     ----------------------------------------------------------------
+c
+ 1010 CONTINUE
+      CLOSE(nulprt)
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/psmile/src/stringop_psmile.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/stringop_psmile.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/stringop_psmile.F90	(revision 1677)
@@ -0,0 +1,262 @@
+
+MODULE stringop_psmile
+  USE mod_kinds_model
+!---------------------------------------------------------------------
+!-
+  INTEGER(kind=ip_intwp_p), DIMENSION(30) :: &
+       & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
+       & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
+!-
+!---------------------------------------------------------------------
+CONTAINS
+!=
+   SUBROUTINE cmpblank (str)
+     USE mod_kinds_model
+!---------------------------------------------------------------------
+!-
+!---------------------------------------------------------------------
+   CHARACTER(LEN=*),INTENT(inout) :: str
+!-
+   INTEGER (kind=ip_intwp_p) :: lcc,ipb
+!---------------------------------------------------------------------
+   lcc = LEN_TRIM(str)
+   ipb = 1
+   DO
+     IF (ipb >= lcc)   EXIT
+     IF (str(ipb:ipb+1) == '  ') THEN
+       str(ipb+1:) = str(ipb+2:lcc)
+       lcc = lcc-1
+     ELSE
+       ipb = ipb+1
+     ENDIF
+   ENDDO
+!-------------------------
+   END SUBROUTINE cmpblank
+!=
+   FUNCTION cntpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds number of occurences of c_r in c_c
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   INTEGER (kind=ip_intwp_p) :: cntpos
+
+   CHARACTER(LEN=*),INTENT(in) :: c_c
+   INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_c
+   CHARACTER(LEN=*),INTENT(in) :: c_r
+   INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_r
+!-
+   INTEGER (kind=ip_intwp_p) :: ipos,indx,ires
+!---------------------------------------------------------------------
+   cntpos = 0
+   ipos   = 1
+   DO
+     indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
+     IF (indx > 0) THEN
+       cntpos = cntpos+1
+       ipos   = ipos+indx+l_r-1
+     ELSE
+       EXIT
+     ENDIF
+   ENDDO
+!---------------------
+   END FUNCTION cntpos
+!=
+   FUNCTION findpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds position of c_r in c_c
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   INTEGER  (kind=ip_intwp_p) :: findpos
+   CHARACTER(LEN=*),INTENT(in) :: c_c
+   INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_c
+   CHARACTER(LEN=*),INTENT(in) :: c_r
+   INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_r
+!---------------------------------------------------------------------
+    findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
+    IF (findpos == 0)   findpos=-1
+!----------------------
+   END FUNCTION findpos
+!=
+   SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a string in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   nb_str      : length of table
+!-   str_tab     : Table  of strings
+!-   str_len_tab : Table  of string-length
+!-   str         : Target we are looking for
+!- OUTPUT
+!-   pos         : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   INTEGER (kind=ip_intwp_p) :: nb_str
+   CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab
+   INTEGER (kind=ip_intwp_p),DIMENSION(nb_str) :: str_len_tab
+   CHARACTER(LEN=*) :: str
+   INTEGER (kind=ip_intwp_p) :: pos
+!-
+   INTEGER (kind=ip_intwp_p) :: i,il
+!---------------------------------------------------------------------
+   pos = -1
+   il = LEN_TRIM(str)
+   IF ( nb_str > 0 ) THEN
+      DO i=1,nb_str
+         IF (     (INDEX(str_tab(i),str(1:il)) > 0) &
+              .AND.(str_len_tab(i) == il) ) THEN
+            pos = i
+            EXIT
+         ENDIF
+      ENDDO
+   ENDIF
+!-------------------------
+   END SUBROUTINE find_str
+!=
+   SUBROUTINE nocomma (str)
+!---------------------------------------------------------------------
+!-
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=*) :: str
+!-
+   INTEGER (kind=ip_intwp_p) :: i
+!---------------------------------------------------------------------
+   DO i=1,LEN_TRIM(str)
+     IF (str(i:i) == ',')   str(i:i) = ' '
+   ENDDO
+!------------------------
+   END SUBROUTINE nocomma
+!=
+   SUBROUTINE strlowercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into lowercase
+!---------------------------------------------------------------------
+   USE mod_kinds_model  
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=*) :: str
+!-
+   INTEGER (kind=ip_intwp_p) :: i,ic
+!---------------------------------------------------------------------
+   DO i=1,LEN_TRIM(str)
+     ic = IACHAR(str(i:i))
+     IF ( (ic >= 65) .AND. (ic <= 90) )   str(i:i) = ACHAR(ic+32)
+   ENDDO
+!-----------------------------
+   END SUBROUTINE strlowercase
+!=
+   SUBROUTINE struppercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into uppercase
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=*) :: str
+!-
+   INTEGER (kind=ip_intwp_p) :: i,ic
+!---------------------------------------------------------------------
+   DO i=1,LEN_TRIM(str)
+     ic = IACHAR(str(i:i))
+     IF ( (ic >= 97) .AND. (ic <= 122) )   str(i:i) = ACHAR(ic-32)
+   ENDDO
+!-----------------------------
+   END SUBROUTINE struppercase
+!=
+!------------------
+   SUBROUTINE gensig (str, sig)
+!---------------------------------------------------------------------
+!- Generate a signature from the first 30 characters of the string
+!- This signature is not unique and thus when one looks for the
+!- one needs to also verify the string.
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   CHARACTER(LEN=*) :: str
+   INTEGER (kind=ip_intwp_p)          :: sig
+!-
+   INTEGER (kind=ip_intwp_p) :: i
+!---------------------------------------------------------------------
+   sig = 0
+   DO i=1,MIN(len_trim(str),30)
+      sig = sig  + prime(i)*IACHAR(str(i:i))
+   ENDDO
+!-----------------------------
+ END SUBROUTINE gensig
+!=
+!------------------
+   SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos)
+!---------------------------------------------------------------------
+!- Find the string signature in a list of signatures
+!---------------------------------------------------------------------
+!- INPUT
+!-   nb_sig      : length of table of signatures
+!-   str_tab     : Table of strings
+!-   str         : Target string we are looking for 
+!-   sig_tab     : Table of signatures
+!-   sig         : Target signature we are looking for
+!- OUTPUT
+!-   pos         : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+   USE mod_kinds_model
+   IMPLICIT NONE
+!-
+   INTEGER (kind=ip_intwp_p) :: nb_sig
+   CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
+   CHARACTER(LEN=*) :: str
+   INTEGER (kind=ip_intwp_p), DIMENSION(nb_sig) :: sig_tab
+   INTEGER (kind=ip_intwp_p) :: sig
+!-
+   INTEGER (kind=ip_intwp_p) :: pos
+   INTEGER (kind=ip_intwp_p), DIMENSION(nb_sig) :: loczeros
+!-
+   INTEGER (kind=ip_intwp_p) :: il, len
+   INTEGER (kind=ip_intwp_p), DIMENSION(1) :: minpos
+!---------------------------------------------------------------------
+!-
+   pos = -1
+   il = LEN_TRIM(str)
+!-
+   IF ( nb_sig > 0 ) THEN
+      !
+      loczeros = ABS(sig_tab(1:nb_sig)-sig)
+      !
+      IF ( COUNT(loczeros < 1) == 1 ) THEN
+         !
+         minpos = MINLOC(loczeros)
+         len = LEN_TRIM(str_tab(minpos(1)))
+         IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+                 .AND.(len == il) ) THEN
+            pos = minpos(1)
+         ENDIF
+         !
+      ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
+         !
+         DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
+            minpos = MINLOC(loczeros)
+            len = LEN_TRIM(str_tab(minpos(1)))
+            IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+                 .AND.(len == il) ) THEN
+               pos = minpos(1)
+            ELSE
+               loczeros(minpos(1)) = 99999
+            ENDIF
+         ENDDO
+         !
+      ENDIF
+      !
+   ENDIF
+!-
+ END SUBROUTINE find_sig
+!=
+!------------------
+END MODULE stringop_psmile
Index: CPL/oasis3/trunk/src/lib/psmile/src/write_file.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/psmile/src/write_file.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/psmile/src/write_file.F90	(revision 1677)
@@ -0,0 +1,781 @@
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** WRITE_FILER4***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At last time step, writes fields to binary files or netcdf files.
+!
+!     interface:
+!     ----------
+!        out_fld : field to be written to the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+! ----------------------------------------------------------------
+  SUBROUTINE write_filer4(out_fld, cd_port,id_port)
+! ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+#include <netcdf.inc>
+! ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port
+    REAL(kind=ip_single_p), intent(in) :: out_fld(myport(4,id_port))
+    CHARACTER(len=8), intent(in) :: cd_port
+! ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p) :: il_unit, il_nolocal, il_err
+    INTEGER (kind=ip_intwp_p) :: ierror, il_varid, il_ncid, istatus
+    LOGICAL :: ll_file
+! ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Write_File '
+!
+!*    Test if restart file is in NETCDF format or not
+!      
+    IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+       istatus = NF_OPEN(cg_def_rstfile(id_port),NF_WRITE,il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_PUT_VAR_REAL (il_ncid, il_varid, out_fld)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_CLOSE(il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+    ELSE
+!
+!* Case binary format
+!
+       IF (.not.allocated(ig_aux)) THEN
+          ALLOCATE (ig_aux(ig_nbr_rstfile), stat=il_err)
+          IF (il_ERR.ne.0) &
+          WRITE(nulprt,*)'Error in "ig_aux" allocation in PRISM_put routine ! '
+          ig_aux(:) = 0
+       ENDIF
+       il_unit = nulprt + 1
+       INQUIRE (il_unit,OPENED = ll_file)
+       DO WHILE (ll_file)
+          il_unit = il_unit + 1 
+          INQUIRE (il_unit,OPENED = ll_file)
+       END DO
+       il_nolocal = ig_def_norstfile(id_port)
+       ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1
+       IF (ig_aux(il_nolocal).eq.1) THEN
+          OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+               FORM='UNFORMATTED')
+       ELSE 
+          OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+               position='append', FORM='UNFORMATTED') 
+       ENDIF
+       CALL locwriter4(cd_port,out_fld,myport(4,id_port),il_unit, &
+            ierror, nulprt) 
+       CLOSE (il_unit)
+    ENDIF
+  END SUBROUTINE write_filer4
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** WRITE_FILER8***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At last time step, writes fields to binary files or netcdf files.
+!
+!     interface:
+!     ----------
+!        out_fld : field to be written to the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE write_filer8(out_fld, cd_port, id_port)
+!     ---------------------------------------------------------------- 
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+    include 'netcdf.inc'
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port
+    CHARACTER(len=8), intent(in) :: cd_port
+    REAL(kind=ip_double_p), intent(in) :: out_fld(myport(4,id_port))
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_err
+    INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, istatus
+    LOGICAL ll_file
+!     ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Write_File '
+!
+!*    Test if restart file is in NETCDF format or not
+!      
+    IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+       istatus = NF_OPEN(cg_def_rstfile(id_port),NF_WRITE,il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_PUT_VAR_DOUBLE (il_ncid, il_varid, out_fld) 
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+       istatus = NF_CLOSE(il_ncid)
+       IF (istatus.ne.NF_NOERR) THEN
+          WRITE(nulprt,*) NF_STRERROR(istatus)
+          WRITE(nulprt,*)' stop in PRISM_put routine '
+          STOP
+       ENDIF
+    ELSE
+!
+!* Case binary format
+!
+       IF (.not.allocated(ig_aux)) THEN
+          ALLOCATE (ig_aux(ig_nbr_rstfile), stat=il_err)
+          IF (il_ERR.ne.0) &
+          WRITE(nulprt,*)'Error in "ig_aux" allocation in PRISM_put routine ! '
+          ig_aux(:) = 0
+       ENDIF
+       il_unit = nulprt + 1
+       INQUIRE (il_unit,OPENED = ll_file)
+       DO WHILE (ll_file)
+          il_unit = il_unit + 1 
+          INQUIRE (il_unit,OPENED = ll_file)
+       END DO
+       il_nolocal = ig_def_norstfile(id_port)
+       ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1
+       IF (ig_aux(il_nolocal).eq.1) THEN
+          OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 
+               FORM='UNFORMATTED')
+       ELSE 
+          OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+               position='append', FORM='UNFORMATTED') 
+       ENDIF
+       CALL locwriter8(cd_port,out_fld,myport(4,id_port),il_unit, &
+            ierror, nulprt) 
+       CLOSE (il_unit)
+    ENDIF
+  END SUBROUTINE write_filer8
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** WRITE_FILE_PARAR4***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, write fields to binary files or netcdf files.
+!
+!     interface:
+!     ----------
+!        out_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE write_file_parar4(out_fld, cd_port,id_port)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+    include 'netcdf.inc'
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    CHARACTER(len=8), intent(in) :: cd_port
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port
+    REAL(kind=ip_single_p), intent(in) :: out_fld(myport(4,id_port))
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100
+    INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_len, il_aux
+    INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, il_status_ncdf
+    INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_rank, iposbuf, il_off
+    INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
+    INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
+    REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_end, rl_work
+    REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
+    LOGICAL ll_file
+    INTEGER(kind=ip_intwp_p)::il_sndreq
+!     ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Write_File_Para '
+!
+!* Each process of local communicator sends his decomposition to master proc
+!
+    IF (mpi_rank .NE. 0) THEN        
+        CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
+           ip_tag, ig_local_comm, ierror )
+        CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
+           ip_tag+1, ig_local_comm, ierror )
+    ENDIF
+!
+!* Master proc receives each process decomposition
+!
+    IF (mpi_rank.eq.0) THEN
+       il_maxgrd = 0
+       ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
+       il_paral_mast(:,:)=0
+!
+!* Master only copies to prevent deadlock
+!
+       il_paral_mast(:,1) = mydist(:,id_port)
+       il_aux = myport(4,id_port)
+       il_maxgrd = il_maxgrd + il_aux
+!
+       DO ib = 1, kbcplproc(ig_mynummod)-1
+          CALL MPI_Recv (il_paral_mast(:,ib+1), & 
+               CLIM_Parsize, MPI_INTEGER, ib, &
+               ip_tag, ig_local_comm, istatus, ierror )
+          CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
+                 ip_tag+1, ig_local_comm, istatus, ierror )
+            il_maxgrd = il_maxgrd + il_aux
+       END DO
+       il_maxbyte = il_maxgrd * 4
+    ENDIF
+!
+!* Each process sends hid part of the field to Master process
+!      
+    ALLOCATE(rl_work(myport(4,id_port)))
+    rl_work(:) = 0
+    iposbuf = 0
+    il_off=1
+    il_len=myport(4,id_port)
+    call MPI_Pack(out_fld(il_off:il_off+il_len-1), &
+         il_len,MPI_REAL,rl_work, &
+         myport(4,id_port)*4,iposbuf,ig_local_comm,ierror)
+    if(mpi_rank.gt.0)then
+    CALL MPI_Send ( rl_work, iposbuf, MPI_PACKED, 0, &
+         ip_tag+2, ig_local_comm, ierror )
+    else
+    CALL MPI_ISend ( rl_work, iposbuf, MPI_PACKED, 0, &
+         ip_tag+2, ig_local_comm, il_sndreq, ierror )
+    endif
+!
+!* Master process receives the part of the field from each process and writes
+!  the entire field to restart file
+!
+    IF (mpi_rank.eq.0) THEN
+       ALLOCATE(rl_work_mast(il_maxgrd))
+       ALLOCATE (rl_end(il_maxgrd))
+       rl_work_mast(:)=0
+       rl_end(:)=0
+       DO ib_rank = 0, kbcplproc(ig_mynummod) - 1
+          CALL MPI_Recv ( rl_work_mast, il_maxbyte, MPI_PACKED, ib_rank , &
+               ip_tag+2, ig_local_comm, istatus, ierror )
+          iposbuf=0
+          DO ib=1,il_paral_mast(clim_segments,ib_rank+1)
+             il_off=il_paral_mast(clim_segments+2*ib-1,ib_rank+1)+1
+             il_len=il_paral_mast(clim_segments+2*ib,ib_rank+1)
+             CALL MPI_Unpack(rl_work_mast, il_maxbyte, iposbuf, &
+                  rl_end(il_off:il_off+il_len-1),il_len, &
+                  MPI_REAL, ig_local_comm, ierror)
+          END DO
+       END DO
+       CALL mpi_wait(il_sndreq,istatus,ierror)
+       DEALLOCATE (rl_work_mast)
+       DEALLOCATE (il_paral_mast)
+!
+!* Test if restart file is in NETCDF format or not
+!
+       IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+          il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port), &
+               NF_WRITE,il_ncid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_PUT_VAR_REAL (il_ncid, il_varid, &
+               rl_end)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_put routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_CLOSE(il_ncid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+       ELSE
+!
+!* Case binary format
+!
+          IF (.not.allocated(ig_aux)) THEN
+             ALLOCATE (ig_aux(ig_nbr_rstfile), stat=ierror)
+             IF (ierror.ne.0) &
+             WRITE(nulprt,*)'Error in "ig_aux" allocation in PRISM_put routine ! '
+             ig_aux(:) = 0
+          ENDIF
+          il_unit = nulprt + 1
+          INQUIRE (il_unit,OPENED = ll_file)
+          DO WHILE (ll_file)
+             il_unit = il_unit + 1 
+             INQUIRE (il_unit,OPENED = ll_file)
+          END DO
+          il_nolocal = ig_def_norstfile(id_port)
+          ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1
+          IF (ig_aux(il_nolocal).eq.1) THEN
+             OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+                  FORM='UNFORMATTED')
+          ELSE 
+             OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+                  position='append', FORM='UNFORMATTED') 
+          ENDIF
+          CALL locwriter4(cd_port,rl_end, il_maxgrd, &
+               il_unit, ierror, nulprt) 
+          CLOSE (il_unit)
+       ENDIF
+       DEALLOCATE(rl_end)
+    ENDIF
+  END SUBROUTINE write_file_parar4
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+!*    *** WRITE_FILE_PARAR8***   PRISM 1.0
+!
+!     purpose:
+!     --------
+!        At first time step, write fields to binary files or netcdf files.
+!
+!     interface:
+!     ----------
+!        out_fld : field to be read from the restart file
+!        cd_port : symbolic name of the field
+!        id_port : port number of the field
+!
+!     lib mp:
+!     -------
+!        mpi-1
+!
+!     author:
+!     -------
+!        Eric Sevault   - METEO FRANCE
+!        Laurent Terray - CERFACS
+!        Jean Latour    - F.S.E.     (mpi-2)
+!        Arnaud Caubel  - Adaptation to PRISM interface
+!     ----------------------------------------------------------------
+  SUBROUTINE write_file_parar8(out_fld, cd_port,id_port)
+!     ----------------------------------------------------------------
+    USE mod_kinds_model
+    USE mod_prism_proto
+    USE mod_comprism_proto
+    IMPLICIT NONE
+    include 'netcdf.inc'
+#include <mpif.h>
+!     ----------------------------------------------------------------
+    CHARACTER(len=8), intent(in) :: cd_port
+    INTEGER (kind=ip_intwp_p), intent(in) :: id_port
+    REAL(kind=ip_double_p), intent(in) :: out_fld(myport(4,id_port))
+!     ----------------------------------------------------------------
+    INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100
+    INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_len, il_aux
+    INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, il_status_ncdf
+    INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_rank, iposbuf, il_off
+    INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
+    INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
+    REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_end, rl_work
+    REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
+    LOGICAL ll_file
+    integer(kind=ip_intwp_p)::il_sndreq
+!     ----------------------------------------------------------------
+    WRITE(nulprt,*)'Entering Write_File_Para '
+!
+!* Each process of local communicator sends his decomposition to master proc
+!
+    IF (mpi_rank .NE. 0) THEN              
+        CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
+           ip_tag, ig_local_comm, ierror )
+        CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
+           ip_tag+1, ig_local_comm, ierror )
+    ENDIF
+!
+!* Master proc receives each process decomposition
+!
+    IF (mpi_rank.eq.0) THEN
+       il_maxgrd = 0
+       ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
+       il_paral_mast(:,:)=0
+!
+!* Master only copies to prevent deadlock
+!
+       il_paral_mast(:,1) = mydist(:,id_port)
+       il_aux = myport(4,id_port)
+       il_maxgrd = il_maxgrd + il_aux
+!
+       DO ib = 1, kbcplproc(ig_mynummod)-1
+          CALL MPI_Recv (il_paral_mast(:,ib+1), &
+               CLIM_Parsize, MPI_INTEGER, ib, &
+               ip_tag, ig_local_comm, istatus, ierror )
+          CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
+                 ip_tag+1, ig_local_comm, istatus, ierror )
+            il_maxgrd = il_maxgrd + il_aux
+       END DO
+       il_maxbyte = il_maxgrd * 8
+    ENDIF
+!
+!* Each process sends hid part of the field to Master process
+!      
+    ALLOCATE(rl_work(myport(4,id_port)))
+    rl_work(:) = 0
+    iposbuf = 0
+    il_off=1
+    il_len=myport(4,id_port)
+    call MPI_Pack(out_fld(il_off:il_off+il_len-1), &
+         il_len,MPI_DOUBLE_PRECISION,rl_work, &
+        myport(4,id_port)*8,iposbuf,ig_local_comm,ierror)
+    if(mpi_rank.gt.0)then
+    CALL MPI_Send ( rl_work, iposbuf, MPI_PACKED, 0, &
+         ip_tag+2, ig_local_comm, ierror )
+    else
+    CALL MPI_ISend ( rl_work, iposbuf, MPI_PACKED, 0, &
+         ip_tag+2, ig_local_comm, il_sndreq, ierror )
+    endif
+!
+!* Master process receives the part of the field from each process and writes
+!  the entire field to restart file
+!
+    IF (mpi_rank.eq.0) THEN
+       ALLOCATE(rl_work_mast(il_maxgrd))
+       ALLOCATE (rl_end(il_maxgrd))
+       rl_work_mast(:)=0
+       rl_end(:)=0
+       DO ib_rank = 0, kbcplproc(ig_mynummod) - 1
+          CALL MPI_Recv ( rl_work_mast, il_maxbyte, MPI_PACKED, ib_rank , &
+               ip_tag+2, ig_local_comm, istatus, ierror )
+          iposbuf=0
+          DO ib=1,il_paral_mast(clim_segments,ib_rank+1)
+             il_off=il_paral_mast(clim_segments+2*ib-1,ib_rank+1)+1
+             il_len=il_paral_mast(clim_segments+2*ib,ib_rank+1)
+             CALL MPI_Unpack(rl_work_mast, il_maxbyte, iposbuf, &
+                  rl_end(il_off:il_off+il_len-1),il_len, &
+                  MPI_DOUBLE_PRECISION, ig_local_comm, ierror)
+          END DO
+       END DO
+       call mpi_wait(il_sndreq,istatus,ierror)
+       DEALLOCATE (rl_work_mast)
+       DEALLOCATE (il_paral_mast)
+!
+!* Test if restart file is in NETCDF format or not
+!
+       IF (lg_ncdfrst) THEN
+!
+!* Case NETCDF format
+!
+          il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port), &
+               NF_WRITE,il_ncid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_PUT_VAR_DOUBLE (il_ncid, il_varid, rl_end) 
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_put routine '
+             STOP
+          ENDIF
+          il_status_ncdf = NF_CLOSE(il_ncid)
+          IF (il_status_ncdf.ne.NF_NOERR) THEN
+             WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
+             WRITE(nulprt,*)' stop in PRISM_get routine '
+             STOP
+          ENDIF
+       ELSE
+!
+!* Case binary format
+!
+          IF (.not.allocated(ig_aux)) THEN
+             ALLOCATE (ig_aux(ig_nbr_rstfile), stat=ierror)
+             IF (ierror.ne.0) &
+             WRITE(nulprt,*)'Error in "ig_aux" allocation in PRISM_put routine ! '
+             ig_aux(:) = 0
+          ENDIF
+          il_unit = nulprt + 1
+          INQUIRE (il_unit,OPENED = ll_file)
+          DO WHILE (ll_file)
+             il_unit = il_unit + 1 
+             INQUIRE (il_unit,OPENED = ll_file)
+          END DO
+          il_nolocal = ig_def_norstfile(id_port)
+          ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1
+          IF (ig_aux(il_nolocal).eq.1) THEN
+             OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+                  FORM='UNFORMATTED')
+          ELSE 
+             OPEN (il_unit, FILE=cg_def_rstfile(id_port), &
+                  position='append', FORM='UNFORMATTED') 
+          ENDIF
+          CALL locwriter8(cd_port,rl_end, il_maxgrd, &
+               il_unit, ierror, nulprt) 
+          CLOSE (il_unit)
+       ENDIF
+       DEALLOCATE(rl_end)
+    ENDIF
+  END SUBROUTINE write_file_parar8
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+  SUBROUTINE locwriter4 (cdfldn, pfield, kdimax, knulre, kflgre, kout)
+    USE mod_kinds_model
+    IMPLICIT none
+!
+!**** *LOCWRITER4*  - Write binary field on unit knulre
+!
+!     Purpose:
+!     -------
+!     Write string cdfldn and array pfield on unit knulre
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *locwrite (cdfldn, pfield, kdimax, knulre, kflgre, kout)*
+!
+!     Input:
+!     -----
+!                cdfldn : character string locator
+!                kdimax : dimension of field to be written 
+!                knulre : logical unit to be written
+!                pfield : field array (real 1D) 
+!                kout   : logical unit to write messages
+!
+!     Output:
+!     ------
+!                kflgre : error status flag
+!
+!     Workspace:
+!     ---------
+!     None
+!
+!     Externals:
+!     ---------
+!     None
+!
+!     Reference:
+!     ---------
+!     See OASIS manual (1995) 
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.0       L. Terray      95/09/01  created
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!
+!* ---------------------------- Argument declarations -------------------
+!
+    INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout
+    REAL(kind=ip_single_p) ::  pfield(kdimax)
+    CHARACTER*8 cdfldn
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Initialization
+!        --------------
+!
+    WRITE (UNIT = kout,FMT = 1001) knulre
+!
+!* Formats
+!
+1001 FORMAT(5X,' Write binary file connected to unit = ',I4)
+!
+!     2. Find field in file
+!        ------------------
+!
+!* Write string
+    WRITE (UNIT = knulre, ERR = 210) cdfldn
+!* Write associated field
+    WRITE (UNIT = knulre, ERR = 210) pfield
+!* Writing done and ok
+    kflgre = 0
+    GO TO 220
+!* Problem in Writing
+210 kflgre = 1
+220 CONTINUE
+!
+!
+!*    3. End of routine
+!        --------------
+!
+    WRITE (UNIT = kout,FMT = *) 'Locwrite : done'
+    CALL FLUSH (kout)
+    RETURN
+  END SUBROUTINE locwriter4
+
+! ********************************************************************
+! ********************************************************************
+! ********************************************************************
+!
+  SUBROUTINE locwriter8 (cdfldn, pfield, kdimax, knulre, kflgre, kout)
+    USE mod_kinds_model
+    IMPLICIT none
+!
+!**** *LOCWRITER8*  - Write binary field on unit knulre
+!
+!     Purpose:
+!     -------
+!     Write string cdfldn and array pfield on unit knulre
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *locwrite (cdfldn, pfield, kdimax, knulre, kflgre, kout)*
+!
+!     Input:
+!     -----
+!                cdfldn : character string locator
+!                kdimax : dimension of field to be written 
+!                knulre : logical unit to be written
+!                pfield : field array (real 1D) 
+!                kout   : logical unit to write messages
+!
+!     Output:
+!     ------
+!                kflgre : error status flag
+!
+!     Workspace:
+!     ---------
+!     None
+!
+!     Externals:
+!     ---------
+!     None
+!
+!     Reference:
+!     ---------
+!     See OASIS manual (1995) 
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.0       L. Terray      95/09/01  created
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!
+!* ---------------------------- Argument declarations -------------------
+!
+    INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout
+    REAL(kind=ip_double_p) ::  pfield(kdimax)
+    CHARACTER*8 cdfldn
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Initialization
+!        --------------
+!
+    WRITE (UNIT = kout,FMT = 1001) knulre
+!
+!* Formats
+!
+1001 FORMAT(5X,' Write binary file connected to unit = ',I4)
+!
+!     2. Find field in file
+!        ------------------
+!
+!* Write string
+    WRITE (UNIT = knulre, ERR = 210) cdfldn
+!* Write associated field
+    WRITE (UNIT = knulre, ERR = 210) pfield
+!* Writing done and ok
+    kflgre = 0
+    GO TO 220
+!* Problem in Writing
+210 kflgre = 1
+220 CONTINUE
+!
+!
+!*    3. End of routine
+!        --------------
+!
+    WRITE (UNIT = kout,FMT = *) 'Locwrite : done'
+    CALL FLUSH (kout)
+    RETURN
+  END SUBROUTINE locwriter8
Index: CPL/oasis3/trunk/src/lib/scrip/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/Makefile	(revision 1677)
@@ -0,0 +1,69 @@
+
+SRCS1 =  $(shell ls ../../../../src/lib/scrip/src/*.F90)
+OBJS1 =  $(patsubst ../../../../src/lib/scrip/src/%.F90, %.o, $(SRCS1))
+
+SRCS4 =  $(shell ls ../../../../src/lib/scrip/src/*.f)
+OBJS4 =  $(patsubst ../../../../src/lib/scrip/src/%.f, %.o, $(SRCS4))
+
+VPATH =	../../../../src/lib/scrip/src:../../../../src/mod/$(COUPLE)/src
+
+LIBRARY	= ../../../lib/libscrip.a
+
+clean:
+	rm -f i.* *.o *.mod
+
+all:	$(LIBRARY)
+
+$(LIBRARY): $(OBJS1) $(OBJS4)
+	$(AR) $(ARFLAGS) $(LIBRARY) $(OBJS1) $(OBJS4)
+
+.SUFFIXES:
+.SUFFIXES: .o .f .F .f90 .F90 .c
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# ALL dependencies ...
+#
+
+kinds_mod.o: mod_kinds_oasis.o
+constants.o: kinds_mod.o
+corners.o: kinds_mod.o mod_parameter.o mod_unitncdf.o mod_label.o mod_printing.o mod_unit.o
+distance.o: kinds_mod.o constants.o
+fracnnei.o: kinds_mod.o constants.o grids.o remap_vars.o mod_unit.o mod_printing.o
+gradient.o: kinds_mod.o constants.o
+gradient_bicubic.o: kinds_mod.o constants.o
+grids.o: kinds_mod.o constants.o iounits.o
+iounits.o: kinds_mod.o
+netcdf.o: kinds_mod.o constants.o
+remap_bicubic.o: kinds_mod.o constants.o grids.o remap_vars.o mod_unit.o mod_printing.o
+remap_bicubic_reduced.o: kinds_mod.o constants.o grids.o remap_vars.o mod_unit.o
+remap_bilinear.o: kinds_mod.o constants.o grids.o remap_vars.o mod_unit.o mod_printing.o
+remap_bilinear_reduced.o: kinds_mod.o constants.o grids.o remap_vars.o mod_unit.o mod_printing.o
+remap_conserv.o: kinds_mod.o constants.o timers.o grids.o remap_vars.o
+remap_distwgt.o: kinds_mod.o constants.o grids.o remap_vars.o
+remap_gauswgt.o: kinds_mod.o constants.o grids.o remap_vars.o
+remap_vars.o: kinds_mod.o constants.o grids.o
+remap_write.o: kinds_mod.o constants.o grids.o remap_vars.o netcdf.o
+scrip.o: kinds_mod.o constants.o iounits.o timers.o grids.o remap_vars.o remap_conserv.o remap_distwgt.o remap_gauswgt.o remap_bilinear.o remap_bicubic.o remap_bilinear_reduced.o remap_bicubic_reduced.o remap_write.o
+scriprmp.o: grids.o remap_vars.o mod_unit.o mod_printing.o
+timers.o: kinds_mod.o
+rotations.o: kinds_mod.o constants.o mod_parameter.o  mod_unitncdf.o mod_unit.o mod_printing.o
+scriprmp_vector.o: grids.o rotations.o
+
+#clean:
+#	rm -f $(OBJS) *.mod
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/constants.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/constants.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/constants.f	(revision 1677)
@@ -0,0 +1,65 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module defines common constants used in many routines.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: constants.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 constants
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod  ! defines common data types
+
+      implicit none
+
+      save
+
+!-----------------------------------------------------------------------
+
+      real (kind = dbl_kind), parameter :: 
+     &                        zero   = 0.0_dbl_kind,
+     &                        one    = 1.0_dbl_kind,
+     &                        two    = 2.0_dbl_kind,
+     &                        three  = 3.0_dbl_kind,
+     &                        four   = 4.0_dbl_kind,
+     &                        five   = 5.0_dbl_kind,
+     &                        half   = 0.5_dbl_kind,
+     &                        quart  = 0.25_dbl_kind,
+     &                        bignum = 1.e+20_dbl_kind,
+     &                        tiny   = 1.e-14_dbl_kind,
+     &                        pi     = 3.14159265358979323846_dbl_kind,
+     &                        pi2    = two*pi,
+     &                        pih    = half*pi
+
+!-----------------------------------------------------------------------
+
+      end module constants
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/corners.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/corners.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/corners.f	(revision 1677)
@@ -0,0 +1,486 @@
+      SUBROUTINE corners(IX, IY, IC, grid_center_lon, grid_center_lat,
+     $      grd_name, cdgrdtyp, grid_corner_lon_2D, grid_corner_lat_2D)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *corners*  - read or calculate grid cell corners
+C
+C     Purpose:
+C     -------
+C     Read grid cell corners from grids file, if awailable.
+C     If not, calculate them from grid center longitudes and latitudes.
+C     This works for logically rectangular grids, only.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *corners*(IX, IY, IC, grid_center_lon, grid_center_lat,
+C          grd_name, cdgrdtyp, grid_corner_lon_2D, grid_corner_lat_2D)
+C
+C     Input:
+C     -----
+C          IX              : number of longitudes
+C          IY              : number of latitudes
+C          IC              : number of corners (=4)
+C          grid_center_lon : grid center longitudes
+C          grid_center_lat : grid center latitudes
+C          grd_name        : string to identify model grid
+C          cdgrdtyp        : string to identify model grid type
+C
+C     Output:
+C     ------
+C          grid_corner_lon_2D : grid corner longitudes (real 2D)
+C          grid_corner_lat_2D : grid corner latitudes  (real 2D)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       V. Gayler      2001/09/20  created
+C       2.5       D. Declat      2002/06/27  MODULE modif.
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Modules --------------------------------
+C
+      USE kinds_mod
+      USE mod_parameter
+      USE mod_unitncdf
+      USE mod_label
+      USE mod_printing
+      USE mod_unit
+C
+C* ---------------------------- Implicit --------------------------------
+C
+      IMPLICIT NONE
+C
+C* ---------------------------- Include files ---------------------------
+C
+      INCLUDE 'netcdf.inc'
+c
+C* ---------------------------- Intent In -------------------------------
+C
+      INTEGER (kind=int_kind), INTENT(IN) ::
+     $     IX,                  ! number of longitudes
+     $     IY,                  ! number of latitudes
+     $     IC                   ! number of grid cell corners
+C
+      REAL (kind=dbl_kind), INTENT(INOUT) ::
+     $     grid_center_lon(IX,IY), ! grid center longitudes
+     $     grid_center_lat(IX,IY)  ! grid center latitudes
+C
+      CHARACTER*8, INTENT(IN) ::
+     $     grd_name,             ! string to specify model grid
+     $     cdgrdtyp              ! string to identify model grid type   
+C
+C* ---------------------------- Intent Out -------------------------------
+C
+      REAL (kind=dbl_kind), INTENT(OUT) :: 
+     $     grid_corner_lon_2D(IC,IX*IY), ! grid corner longitudes
+     $     grid_corner_lat_2D(IC,IX*IY)  ! grid corner latitudes
+C
+C* ---------------------------- Local declarations ----------------------
+C   
+      INTEGER (kind=int_kind) ::
+     $     i, j, c, ij,         ! looping indicees: lon, lat, corner
+     $     ip1, im1, jp1, jm1,  !
+     $     c1, c2, c3, c4,
+     $     icount,               ! number of characters in string
+     $     ilenstr              ! external function
+C
+      REAL (kind=dbl_kind)  :: 
+     $     aux(IC,IX,IY),
+     $     grid_corner_lon(IX,IY,IC), ! grid corner longitudes (3D)
+     $     grid_corner_lat(IX,IY,IC), ! grid corner latitudes  (3D)
+     $     lon1, lon2, lon3, lon4, ! center lon. of surrounding a corner
+     $     lat1, lat2, lat3, lat4, ! center lat. of surrounding a corner
+     $     lon21, lon12,        !
+     $     x1, x2, x3, x4,      ! transformed to x/y/z coordinates
+     $     y1, y2, y3, y4,      !      ''         ''       ''
+     $     z1, z2, z3, z4,      !      ''         ''       ''
+     $     vp,                  ! vector product
+     $     xmean, ymean, zmean, ! mean values   
+     $     radius,              ! vector lenght
+     $     zconva, zconvb,      ! conversion factors
+     $     PI                   ! pi
+C
+      CHARACTER*8 ::
+     $     ccrnlon,             ! string: corner longitude
+     $     ccrnlat,             !   ''    corner latitude
+     $     clon                 !   ''    longitude
+C
+C* -- netCDF-declarations
+      INTEGER (kind=int_kind) ::
+     $     stat,                ! netCDF status
+     $     start(3), count(3),  ! start and count vector for NF_PUT_VARA
+     $     varid,               ! variable id
+     $     idcrnlon,            ! variable id: corner longitudes
+     $     idcrnlat,            ! variable id: corner latitudes
+     $     idlon,               ! variable id: center longitudes
+     $     vtype,               ! variable type
+     $     ndims,               ! number of dimensions
+     $     vardims(3),          ! corner array dimensions
+     $     londims(2),          ! dimensions of longitude array
+     $     crndim               ! corner dimension
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE corners  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $         ' Get grid cell corners for grid: ', grd_name
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C*    2. Look for corners in grids file
+C*       ------------------------------
+C
+C* -- get locator string
+C
+      icount = ilenstr(grd_name,jpeight)
+      ccrnlon = grd_name(1:icount)//crnlonsuf
+      ccrnlat = grd_name(1:icount)//crnlatsuf
+C
+      start = (/1,1,1/)
+      count = (/IX,IY,IC/)
+C
+      IF (lncdfgrd) THEN
+          CALL hdlerr
+     $        (NF_OPEN(cgrdnam//'.nc',NF_WRITE,nc_grdid),'corners')
+          stat = NF_INQ_VARID(nc_grdid, ccrnlon, varid)
+          IF (stat .lt. 0) THEN
+              IF (cdgrdtyp .ne. 'LR') THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'File grids.nc contains no corner information,'
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'and grid is not logically rectangular.'
+                  CALL HALTE('STOP in corners.f')
+              ELSE
+                  WRITE (UNIT = nulou,FMT = *) 
+     $          'WARNING: File grids.nc contains no corner information'
+                  WRITE (UNIT = nulou,FMT = *) 
+     $           'OASIS will calculate it with basic algorithm' 
+                  WRITE (UNIT = nulou,FMT = *) 
+     $           'See corner.f'  
+              ENDIF
+          ENDIF
+      ELSE
+          IF (cdgrdtyp .ne. 'LR') THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'File grids.nc does not exist'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'and grid is not logically rectangular.'
+              CALL HALTE('STOP in corners.f')
+          ELSE
+              stat = -1
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'WARNING: as NetCDF FILE grids.nc does not exists,'
+              WRITE (UNIT = nulou,FMT = *) 
+     $           'OASIS will calculate corner information' 
+              WRITE (UNIT = nulou,FMT = *) 
+     $           'with basic algorithm. See corner.f'
+          ENDIF
+      ENDIF
+C
+      IF (stat == 0) THEN
+C*    -- read corner longitudes
+          CALL hdlerr
+     $        (NF_INQ_VARTYPE(nc_grdid, varid, vtype), 'corners')
+         IF (vtype .eq. NF_FLOAT) THEN
+            CALL hdlerr(NF_GET_VARA_REAL (nc_grdid, varid, 
+     $           start, count, grid_corner_lon),'corners')
+         ELSE IF (vtype .eq. NF_DOUBLE) THEN
+            CALL hdlerr(NF_GET_VARA_DOUBLE (nc_grdid, varid, 
+     $           start, count, grid_corner_lon),'corners')
+         ELSE
+            CALL prcout 
+     $           ('Problem with type of corner array =', ccrnlon, 1) 
+            CALL HALTE('STOP in corners')
+         ENDIF
+C*    -- read corner latitudes
+         ccrnlat = grd_name(1:icount)//crnlatsuf
+         CALL hdlerr(NF_INQ_VARID(nc_grdid, ccrnlat, varid), 'corners')
+         CALL hdlerr
+     $        (NF_INQ_VARTYPE(nc_grdid, varid, vtype), 'corners')
+         IF (vtype .eq. NF_FLOAT) THEN
+            CALL hdlerr(NF_GET_VARA_REAL (nc_grdid, varid, 
+     $           start, count, grid_corner_lat),'corners')
+         ELSE IF (vtype .eq. NF_DOUBLE) THEN
+            CALL hdlerr(NF_GET_VARA_DOUBLE (nc_grdid, varid, 
+     $           start, count, grid_corner_lat),'corners')
+         ELSE
+            CALL prcout
+     $           ('Problem with type of corner array =', ccrnlat, 1) 
+            CALL HALTE('STOP in corners')
+         ENDIF
+         IF (nlogprt .GE. 2) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $            ' Read corner longitudes and latitudes from grids.nc'
+         ENDIF 
+C     
+      ELSE
+         IF (cdgrdtyp .ne. 'LR') THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'Corner longitudes and latitudes are not'
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'defined in grids.nc and cannot be calculated'
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'by Oasis as grid is not logically rectangular'
+            CALL HALTE('STOP in corners')
+        ENDIF
+C
+C*   3. Calculate corners from center latitudes and longitudes
+C*      ------------------------------------------------------
+        IF (nlogprt .GE. 2) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $          ' Calculate corner longitudes and latitudes'
+        ENDIF 
+C   
+C*   -- convert longitudes/latitudes to radians
+C
+        zconva = 1.74532925199432957692e-2 ! =PI/180
+        zconvb = 1/zconva 
+        PI = zconva * 180
+C
+        grid_center_lon = grid_center_lon * zconva
+        grid_center_lat = grid_center_lat * zconva
+C
+        WHERE (grid_center_lon < -PI)
+            grid_center_lon = grid_center_lon + 2*PI
+        END WHERE
+        WHERE (grid_center_lon > PI)
+            grid_center_lon = grid_center_lon - 2*PI
+        END WHERE
+C
+C*   -- Calculate vectorproduct to find out the grid order
+C
+        lon12 = grid_center_lon(1,2)
+        lon21 = grid_center_lon(2,1)
+        IF ((lon21 - grid_center_lon(1,1)) >  PI) THEN
+            lon21 = lon21 + 2*PI
+        ELSE IF ((lon21 - grid_center_lon(1,1)) < -PI) THEN
+            lon21 = lon21 + 2*PI
+        ELSE IF ((lon12 - grid_center_lon(1,1)) >  PI) THEN
+            lon12 = lon12 - 2*PI
+        ELSE IF ((lon12 - grid_center_lon(1,1)) < -PI) THEN
+            lon12 = lon12 + 2*PI
+        ENDIF
+C
+        vp =  ((lon21                - grid_center_lon(1,1)) 
+     $        * (grid_center_lat(1,2) - grid_center_lat(1,1)))
+     $       - ((lon12                - grid_center_lon(1,1)) 
+     $        * (grid_center_lat(2,1) - grid_center_lat(1,1)))
+        IF (vp < 0) THEN
+            c1 = 1
+            c2 = 2
+            c3 = 3
+            c4 = 4
+        ELSE
+            c1 = 4
+            c2 = 3
+            c3 = 2
+            c4 = 1
+        ENDIF
+C
+C*    -- Grid corner latitudes and longitudes
+C
+	DO i = 1, IX            ! loop longitudes
+          im1 = i-1
+          IF (i == 1)  im1 = IX
+          ip1 = i+1
+          IF (i == IX) ip1 = 1
+c           DO j = 2, IY-1          ! loop latitudes
+          DO j = 1, IY            ! loop latitudes
+            jm1 = j-1
+            IF (j == 1) jm1 = 1
+            jp1 = j+1
+            IF (j == IY) jp1 = IY
+            DO c = 1, IC        ! loop corners
+              IF (c == c1) THEN
+                  lon1 = grid_center_lon(ip1,jm1)
+                  lon2 = grid_center_lon(i  ,jm1)
+                  lon3 = grid_center_lon(i  ,j  )
+                  lon4 = grid_center_lon(ip1,j  )
+                  lat1 = grid_center_lat(ip1,jm1)
+                  lat2 = grid_center_lat(i  ,jm1)
+                  lat3 = grid_center_lat(i  ,j  )
+                  lat4 = grid_center_lat(ip1,j  )
+              ELSE IF (c == c2) THEN
+                  lon1 = grid_center_lon(i  ,jm1)
+                  lon2 = grid_center_lon(im1,jm1)
+                  lon3 = grid_center_lon(im1,j  )
+                  lon4 = grid_center_lon(i  ,j  )
+                  lat1 = grid_center_lat(i  ,jm1)
+                  lat2 = grid_center_lat(im1,jm1)
+                  lat3 = grid_center_lat(im1,j  )
+                  lat4 = grid_center_lat(i  ,j  )
+              ELSE IF (c == c3) THEN
+                  lon1 = grid_center_lon(i  ,j  )
+                  lon2 = grid_center_lon(im1,j  )
+                  lon3 = grid_center_lon(im1,jp1)
+                  lon4 = grid_center_lon(i  ,jp1)
+                  lat1 = grid_center_lat(i  ,j  )
+                  lat2 = grid_center_lat(im1,j  )
+                  lat3 = grid_center_lat(im1,jp1)
+                  lat4 = grid_center_lat(i  ,jp1)
+              ELSE IF (c == c4) THEN
+                  lon1 = grid_center_lon(ip1,j  )
+                  lon2 = grid_center_lon(i  ,j  )
+                  lon3 = grid_center_lon(i  ,jp1)
+                  lon4 = grid_center_lon(ip1,jp1)
+                  lat1 = grid_center_lat(ip1,j  )
+                  lat2 = grid_center_lat(i  ,j  )
+                  lat3 = grid_center_lat(i  ,jp1)
+                  lat4 = grid_center_lat(ip1,jp1)
+              ENDIF
+C
+C*             -- Transformation to x/y/z coordinates
+C
+              x1 = cos(lat1)*cos(lon1)
+              x2 = cos(lat2)*cos(lon2)
+              x3 = cos(lat3)*cos(lon3)
+              x4 = cos(lat4)*cos(lon4)
+C
+              y1 = cos(lat1)*sin(lon1)
+              y2 = cos(lat2)*sin(lon2)
+              y3 = cos(lat3)*sin(lon3)
+              y4 = cos(lat4)*sin(lon4)
+C
+              z1 = sin(lat1)
+              z2 = sin(lat2)
+              z3 = sin(lat3)
+              z4 = sin(lat4)
+C
+C*             -- Interpolation
+C
+              xmean = (x1 + x2 + x3 + x4) / 4.
+              ymean = (y1 + y2 + y3 + y4) / 4.
+              zmean = (z1 + z2 + z3 + z4) / 4.
+C
+              radius = SQRT(xmean**2 + ymean**2 + zmean**2)
+C
+              xmean = xmean/radius
+              ymean = ymean/radius
+              zmean = zmean/radius
+C     
+C*             -- Transformation to lat/lon coordinates
+C
+              grid_corner_lat(i,j,c) = ASIN(zmean)
+              IF (ymean > 0. .AND. xmean > 0.) THEN
+                  grid_corner_lon(i,j,c) = ATAN(ymean/xmean)
+              ELSE IF (ymean > 0. .AND. xmean < 0.) THEN
+                  grid_corner_lon(i,j,c) = PI + ATAN(ymean/xmean)
+              ELSE IF (ymean < 0. .AND. xmean < 0.) THEN
+                  grid_corner_lon(i,j,c) = -PI + ATAN(ymean/xmean)
+              ELSE IF (ymean < 0. .AND. xmean > 0.) THEN
+                  grid_corner_lon(i,j,c) = ATAN(ymean/xmean)
+              ENDIF
+C
+            ENDDO               ! corners
+          ENDDO                 ! latitudes
+        ENDDO                   ! longitudes
+C
+C*    -- Transformation from radians to degrees
+C
+        grid_center_lon = grid_center_lon * zconvb
+        grid_center_lat = grid_center_lat * zconvb
+        grid_corner_lon = grid_corner_lon * zconvb
+        grid_corner_lat = grid_corner_lat * zconvb
+C
+C*    -- write corner longitudes and latitudes to grids-file
+C
+        IF ( .not. lncdfgrd) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $          'WARNING: corner longitudes and latitudes'
+            WRITE (UNIT = nulou,FMT = *) 
+     $          'cannot be written to file grids'
+            WRITE (UNIT = nulou,FMT = *) 
+     $          'as it is not in NetCDF FORMAT.'
+        ELSE
+            clon = grd_name(1:icount)//cglonsuf
+            CALL hdlerr(NF_INQ_VARID
+     $          (nc_grdid, clon, idlon), 'corners')
+            CALL hdlerr(NF_INQ_VARDIMID
+     $          (nc_grdid, idlon, londims), 'corners')
+            CALL hdlerr(NF_REDEF(nc_grdid), 'corners')
+            stat = NF_INQ_DIMID(nc_grdid, 'corners', crndim)
+            IF (stat .NE. NF_NOERR) THEN
+                CALL hdlerr(NF_DEF_DIM
+     $              (nc_grdid, 'corners', IC, crndim), 'corners')
+            ENDIF
+            ndims = 3
+            vardims(1) = londims(1)
+            vardims(2) = londims(2)
+            vardims(3) = crndim
+            IF (KIND(1.0) == 8) THEN
+                CALL hdlerr(NF_DEF_VAR(nc_grdid, ccrnlon,
+     $              NF_DOUBLE, ndims, vardims, idcrnlon), 'corners')
+                CALL hdlerr(NF_DEF_VAR(nc_grdid, ccrnlat,
+     $              NF_DOUBLE, ndims, vardims, idcrnlat), 'corners')
+                CALL hdlerr(NF_ENDDEF(nc_grdid), 'corners')
+                CALL hdlerr(NF_PUT_VARA_DOUBLE(nc_grdid, idcrnlon, 
+     $              start, count, grid_corner_lon), 'corners')
+                CALL hdlerr(NF_PUT_VARA_DOUBLE(nc_grdid, idcrnlat, 
+     $              start, count, grid_corner_lat), 'corners')
+            ELSE
+                CALL hdlerr(NF_DEF_VAR(nc_grdid, ccrnlon,
+     $              NF_REAL, ndims, vardims, idcrnlon), 'corners')
+                CALL hdlerr(NF_DEF_VAR(nc_grdid, ccrnlat,
+     $              NF_REAL, ndims, vardims, idcrnlat), 'corners')
+                CALL hdlerr(NF_ENDDEF(nc_grdid), 'corners')
+                CALL hdlerr(NF_PUT_VARA_REAL(nc_grdid, idcrnlon, 
+     $              start, count, grid_corner_lon), 'corners')
+                CALL hdlerr(NF_PUT_VARA_REAL(nc_grdid, idcrnlat,
+     $              start, count, grid_corner_lat), 'corners')
+            ENDIF
+C
+            IF (nlogprt .GE. 2) THEN
+                WRITE (UNIT = nulou,FMT = *) ' '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' Wrote corner longitudes and latitudes'
+            ENDIF 
+C
+        ENDIF
+      ENDIF
+C
+C*    4. Resize corner arrays
+C*       --------------------
+C
+      DO i = 1, IX
+        DO j = 1, IY
+          ij = ((j-1)*IX)+i
+          DO c = 1, IC
+            grid_corner_lon_2D(c,ij) = grid_corner_lon(i,j,c)
+            grid_corner_lat_2D(c,ij) = grid_corner_lat(i,j,c)
+          ENDDO
+        ENDDO
+      ENDDO
+C
+C*    5. End of routine
+C*       --------------
+C
+      IF ( lncdfgrd) CALL hdlerr(NF_CLOSE(nc_grdid), 'corners')
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine corners ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END SUBROUTINE corners
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/distance.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/distance.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/distance.f	(revision 1677)
@@ -0,0 +1,83 @@
+       FUNCTION distance (lon1, lat1, lon2, lat2)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *distance*  - calculate the distance between two points on a sphere
+C
+C     Purpose:
+C     -------
+C     Calculation of the distance between two points on a sphere
+C       1. Transformation to x,y,z-coordinates
+C       2. Calculating the distance
+C       3. Calculating the distance on the sphere
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *distance*(lon1, lat1, lon2, lat2)
+C
+C     Input:
+C     -----
+C          lon1              : longitude of first point (rad)
+C          lat1              : latitude of first point (rad)
+C          lon2              : longitude of second point (rad)
+C          lat2              : latitude of second point (rad)
+C
+C     Output:
+C     ------
+C          distance          : distance
+CC
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       V. Gayler      2001/09/20  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      USE constants
+      USE kinds_mod
+
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     INTENT(IN)
+!-----------------------------------------------------------------------
+      REAL (kind=real_kind), INTENT(IN) :: 
+     $     lon1,                ! longitude of first point (rad)
+     $     lon2,                ! longitude of second point (rad)
+     $     lat1,                ! latitude of first point (rad)
+     $     lat2                 ! latitude of second point (rad)
+
+!-----------------------------------------------------------------------
+!     LOKAL VARIABLES
+!-----------------------------------------------------------------------
+      REAL (kind=real_kind) ::
+     $     x1, y1, z1,          ! coordinates of the first point
+     $     x2, y2, z2,          ! coordinates of the second point
+     $     distance             ! distance between the points (rad)
+
+!-----------------------------------------------------------------------
+
+!     Transformation to x,y,z-coordinates
+!     -----------------------------------
+      x1 = cos(lat1)*cos(lon1)
+      y1 = cos(lat1)*sin(lon1)
+      z1 = sin(lat1)
+
+      x2 = cos(lat2)*cos(lon2)
+      y2 = cos(lat2)*sin(lon2)
+      z2 = sin(lat2)
+
+!     Calculation of the distance
+!     ---------------------------
+!     direct distance:
+      distance = SQRT((x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2)
+
+!     distance along the surface:
+      distance = 2*ASIN(distance/2)
+
+!-----------------------------------------------------------------------
+      RETURN 
+      END FUNCTION distance
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/fracnnei.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/fracnnei.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/fracnnei.f	(revision 1677)
@@ -0,0 +1,266 @@
+      subroutine fracnnei (src_size, dst_size,
+     $    ld_srcmask, ld_dstmask,
+     $    src_lon, src_lat, dst_lon, dst_lat,
+     $    num_links, num_wgts,
+     $    weights, src_addr, dst_addr)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 4 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *fracnnei* - SCRIP remapping
+C
+C     Purpose:
+C     -------
+C     Treatment of the tricky points in an interpolation
+C
+C     Interface:
+C     ---------
+C       *CALL*  *
+C
+C     Called from:
+C     -----------
+C     scriprmp
+C
+C     Input:
+C     -----
+C             src_size    : source grid size (integer)
+C             dst_size    : target grid size (integer)
+C             ld_srcmask  : mask of the source grid
+C             ld_dstmask  : mask of the target grid
+C             src_lon     : longitudes of the source grid
+C             src_lat     : latitudes of the source grid
+C             dst_lon     : longitudes of the target grid
+C             dst_lat     : latitudes of the target grid
+C             num_links   : total number of links
+C             num_wgts    : number of weights for each link
+C     InOut
+C     -----
+C             weights     : remapping weights
+C             src_addr    : remapping source addresses
+C             dst_addr    : remapping target addresses
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       D.Declat       2002/08/20  adapted from S. Valcke ptmsq
+C       3.0       S. Valcke      2002/10/30  test and corrections
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C* ---------------------------- Modules used ----------------------------
+C
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid information
+      use remap_vars    ! module containing remap information
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Implicit --------------------------------
+C
+      implicit none
+C
+C* ---------------------------- Include files ---------------------------
+C
+
+C      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Intent In -------------------------------
+C
+      INTEGER (kind=int_kind) ::
+     $    src_size,             ! size of the source grid
+     $    dst_size              ! size of the destination grid
+C
+      REAL (kind=dbl_kind) ::
+     $    src_lat(src_size), src_lon(src_size),
+     $    dst_lat(dst_size), dst_lon(dst_size)
+
+C
+      LOGICAL ::
+     $    ld_srcmask(src_size),   ! source grid mask
+     $    ld_dstmask(dst_size)    ! target grid mask
+C
+      INTEGER (kind=int_kind) ::
+     $    num_links,      ! number of links between src and tgt
+     $    num_wgts        ! number of weights
+
+C
+C* ---------------------------- Intent InOut ------------------------------
+C
+      REAL (kind=dbl_kind) ::
+     $    weights(num_wgts, num_links) ! remapping weights
+C
+      INTEGER (kind=int_kind) ::
+     $    src_addr(num_links), ! remapping source addresses
+     $    dst_addr(num_links)  ! remapping target addresses
+C
+C* ---------------------------- Local declarations ----------------------
+C
+C
+      INTEGER (kind=int_kind) :: 
+     $    ila_nneiadd           ! Nearest-neighbor address
+C
+      INTEGER (kind=int_kind) ::
+     $    ib_dst,               ! INDEX loop for the distance grid
+     $    ib_src,               ! INDEX loop for the source grid
+     $    ib_neigh,             ! INDEX loop on the corresponding src pts
+     $    ib_links              ! INDEX loop for the links      
+C
+      INTEGER (kind=int_kind) ::
+     $    nb_Vmm,               ! number of Mtt points
+     $    ntottotland,          ! number of land points
+     $    ntotland,             ! number of land points
+     $    ntotoce,              ! number of oceanic points
+     $    ntotngh               ! number of corresponding source points
+C
+      INTEGER (kind=int_kind) ::
+     $    beg_links,            ! begining of the serie of links
+     $    nb_links              ! number of links
+C
+      REAL (kind=dbl_kind) ::
+     $    coslat,               ! cosinus of the latitude
+     $    sinlat,               ! sinus of the latitude
+     $    coslon,               ! cosinus of the longitude
+     $    sinlon,               ! sinus of the longitude
+     $    distance, 
+     $    dist_min
+C
+      INTEGER (kind=int_kind) :: n
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        '           ROUTINE fracnnei  -  Level 4'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Treating the tricky points of the remapping'
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C *----------------------------------------------------------------------
+C
+C*    2. Treating Vmm points   V
+C        -------------------  m m
+C     The target point is a non-masked Valid point while the source points 
+C         are all masked points. Use of 4 non-masked nearest neighbours.
+C
+      nb_Vmm = 0
+      ntottotland = 0
+      beg_links = 1
+      PRINT *,'Vmm treatment'
+
+C* -- Loop all other the target points
+      PRINT *, 'dst_size =', dst_size
+      DO ib_dst = 1, dst_size
+C* -- If the point is a sea point
+        IF (ld_dstmask(ib_dst)) THEN
+
+            beg_links = 0
+
+            DO ib_links = 1, num_links
+              IF (ib_dst .eq. 7783 .and. dst_addr(ib_links) 
+     $            .eq. 7783) THEN
+                  PRINT *, 'dst_addr(ib_links)= 7783 for ', ib_links
+              ENDIF
+              IF (dst_addr(ib_links) .eq. ib_dst) THEN
+                  beg_links = ib_links
+                  exit
+              ENDIF
+            END DO 
+
+            IF (beg_links .ne. 0) THEN
+
+                ntotland = 0
+                ntotoce = 0
+                ntotngh = 0
+
+C* -- Find the number of associated src points to the non-masked tgt point
+                nb_links = 1
+                DO WHILE (dst_addr(beg_links) .eq. 
+     $              dst_addr(beg_links+nb_links))
+                  nb_links = nb_links + 1
+                END DO
+                
+C* -- For each point on the src grid associated to the non-masked tgt point
+                DO ib_neigh = 1, nb_links
+C
+                  ntotngh = ntotngh + 1
+
+C* -- Check IF the point is a masked or non-masked point and treat it
+                  IF (.not. ld_srcmask(src_addr(beg_links+ib_neigh-1)))
+     $                THEN
+C                      PRINT *,'Mtt Ici dans la terre'
+                      ntotland = ntotland + 1
+                      ntottotland = ntottotland + 1
+                  ELSE IF (ld_srcmask(src_addr(beg_links+ib_neigh-1))) 
+     $                    THEN
+C                  PRINT *,'Mtt Ici dans la mer'
+                      ntotoce = ntotoce + 1
+                  ELSE
+                      WRITE (*, *) 'Pb with ocean mask with Mtt 1' 
+                  END IF
+
+                END DO
+ 
+C* -- If all the src points are land, treat it !
+                IF (ntotland .EQ. ntotngh) THEN
+                    nb_Vmm = nb_Vmm + 1
+                    PRINT *, 'nb_Vmm, ib_dst, ntotland, ntotngh =', 
+     $                  ib_dst, ntotland, ntotngh
+
+C* -- Find the nearest neighbours and change weights and address 
+
+                    coslat = cos(dst_lat(ib_dst))
+                    sinlat = sin(dst_lat(ib_dst))
+                    coslon = cos(dst_lon(ib_dst))
+                    sinlon = sin(dst_lon(ib_dst))
+
+                    dist_min = bignum
+                    ila_nneiadd = 0
+                    DO ib_src = 1, src_size
+                      IF (ld_srcmask(ib_src)) THEN
+                          distance = acos(coslat*cos(src_lat(ib_src))*
+     &                        (coslon*cos(src_lon(ib_src)) +
+     &                        sinlon*sin(src_lon(ib_src)))+
+     &                        sinlat*sin(src_lat(ib_src)))
+                          IF (distance < dist_min) THEN
+                              ila_nneiadd = ib_src
+                              dist_min = distance
+                          ENDIF
+                      ENDIF
+                    END DO
+                    src_addr(beg_links) = ila_nneiadd
+                    weights(1,beg_links) = 1.0
+                    IF (nb_links > 1) then
+                        DO n=2, nb_links
+                          src_addr(beg_links+n-1)=0
+                          weights(1,beg_links+n-1)=0.0
+                        END DO
+                    END IF
+                END IF
+            END IF
+        ENDIF
+      END DO
+C
+      PRINT *,'End Case Vmm', nb_Vmm, ntottotland
+C
+C *----------------------------------------------------------------------
+C
+
+      END SUBROUTINE fracnnei
+
+!***********************************************************************
+
+  
Index: CPL/oasis3/trunk/src/lib/scrip/src/gradient.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/gradient.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/gradient.f	(revision 1677)
@@ -0,0 +1,223 @@
+      subroutine gradient(NX1, NY1, src_array, sou_mask,
+     $                    src_latitudes, src_longitudes,
+     $                            id_nosper,
+     $                    grad_lat, grad_lon)
+
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *gradient*  - calculate gradients for conservative remapping
+C
+C     Purpose:
+C     -------
+C     Calculation of gradients in latitudinal and longitudinal direction.
+C     In a first step the gradients in direction of source-grid rows  
+C     and lines are calculated. Then they are rotated to longitudinal 
+C     and latitudinal direction, using the scalar product.
+C     This routine works for logically rectangular grids, only.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *gradient*(NX1, NY1, src_array, sou_mask, src_latitudes,
+C     $          src_longitudes, grad_lat, grad_lon)
+C
+C     Input:
+C     -----
+C          NX1            : grid dimension in x-direction (integer)
+C          NY1            : grid dimension in y-direction (integer)
+C          src_array      : array on source grid (real 2D)
+C          sou_mask       : source grid mask (integer 2D)
+C          src_latitudes  : latitudes on source grid (real 2D)
+C          src_longitudes : longitudes on source grid (real 2D)
+C          id_nosper      : number of overlapping points for source grid
+C
+C     Output:
+C     ------
+C          grad_lat       : gradient in latitudinal direction (real 2D)
+C          grad_lon       : gradient in longitudinal direction (real 2D)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       V. Gayler      2001/09/20  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      USE constants
+      USE kinds_mod
+
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     INTENT(IN)
+!-----------------------------------------------------------------------
+      INTEGER (int_kind), INTENT(IN) ::
+     $     NX1, NY1,             ! source grid dimensions
+     $    id_nosper             ! nbr of overlapping grid points
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     src_array            ! array on source grid
+
+      INTEGER (int_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     sou_mask             ! source grid mask
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     src_latitudes,       ! source grid latitudes
+     $     src_longitudes       ! source grid longitudes
+
+!-----------------------------------------------------------------------
+!     INTENT(OUT)
+!-----------------------------------------------------------------------
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(OUT) ::
+     $     grad_lat,            ! gradient in latitudinal direction
+     $     grad_lon             ! gradient in longitudinal direction
+
+!-----------------------------------------------------------------------
+!     LOCAL VARIABLES
+!-----------------------------------------------------------------------
+      INTEGER (int_kind) ::
+     $     i, j,                ! looping indicees
+     $     ip1, jp1, im1, jm1
+
+      REAL (kind = real_kind) ::
+     $     distance             ! distance in rad
+     
+      REAL (kind = real_kind) ::
+     $     dVar_i, dVar_j,      ! difference of Var in i / j direction
+     $     dlat_i, dlat_j,      ! difference in lat in i / j direction
+     $     dlon_i, dlon_j,      ! difference in lon in i / j direction
+     $     dist_i, dist_j,      ! distance in i / j direction
+     $     grad_i, grad_j,      ! gradient in i / j direction
+     $     ABSold, ABSnew, lat_factor
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1) ::
+     $     src_lon,             ! source grid longitudes [radiants]
+     $     src_lat,             ! source grid latitudes [radiants]
+     $     pi180                ! conversion factor: deg -> rad
+
+      INTEGER (int_kind) ::  il_maskval= 0_int_kind
+
+!-----------------------------------------------------------------------
+
+!     Transformation from degree to radiant
+!     -------------------------------------
+      pi180 = 1.74532925199432957692e-2 ! =PI/180
+
+      src_lon = src_longitudes * pi180
+      src_lat = src_latitudes * pi180
+
+!-----------------------------------------------------------------------
+
+      DO i = 1, NX1
+
+         DO j = 1, NY1
+                   
+            IF (sou_mask(i,j) /= il_maskval) THEN
+
+               ip1 = i + 1
+               im1 = i - 1
+               IF (i == NX1) ip1 = 1 + id_nosper  ! the 0-meridian
+               IF (i == 1 )  im1 = NX1 - id_nosper
+               jp1 = j + 1
+               jm1 = j - 1
+               IF (j == NY1) jp1 = NY1 ! treatment of the last..
+               IF (j == 1 )  jm1 = 1   ! .. and the first grid-row
+
+               IF (sou_mask(ip1,j) == il_maskval)  ip1 = i
+               IF (sou_mask(im1,j) == il_maskval)  im1 = i
+               IF (sou_mask(i,jp1) == il_maskval)  jp1 = j
+               IF (sou_mask(i,jm1) == il_maskval)  jm1 = j          
+
+!              difference between neighbouring datapoints
+               dVar_i = src_array(ip1,j) - src_array(im1,j)
+               dVar_j = src_array(i,jp1) - src_array(i,jm1)
+
+!              difference in latitudes
+               dlat_i = src_lat(ip1,j) - src_lat(im1,j)
+               dlat_j = src_lat(i,jp1) - src_lat(i,jm1)
+
+!              difference in longitudes
+               dlon_i = src_lon(ip1,j) - src_lon(im1,j)
+               IF (dlon_i >   PI)  dlon_i = dlon_i - PI2
+               IF (dlon_i < (-PI)) dlon_i = dlon_i + PI2
+               dlon_j = src_lon(i,jp1) - src_lon(i,jm1)
+               IF (dlon_j >   PI)  dlon_j = dlon_j - PI2
+               IF (dlon_j < (-PI)) dlon_j = dlon_j + PI2
+               lat_factor = cos(src_lat(i,j))
+               dlon_i = dlon_i * lat_factor
+               dlon_j = dlon_j * lat_factor
+ 
+!              distance
+               dist_i = distance(src_lon(ip1,j), src_lat(ip1,j),
+     $                           src_lon(im1,j), src_lat(im1,j))
+               dist_j = distance(src_lon(i,jp1), src_lat(i,jp1),
+     $                           src_lon(i,jm1), src_lat(i,jm1))
+
+!              gradients: dVar / distance (= vector lenght)
+               IF (dist_i /= 0.) THEN
+                  grad_i = dVar_i / dist_i
+               ELSE
+                  grad_i = 0
+               ENDIF
+               IF (dist_j /= 0.) THEN
+                  grad_j = dVar_j / dist_j
+               ELSE
+                  grad_j = 0
+               ENDIF
+
+!              projection by scalar product
+!              ----------------------------
+               grad_lon(i,j) = grad_i * dlon_i + grad_j * dlat_i
+               grad_lat(i,j) = grad_i * dlon_j + grad_j * dlat_j
+
+               if (dist_i /= 0) then
+                  grad_lon(i,j) = grad_lon(i,j) / dist_i
+               else
+                  grad_lon(i,j) = 0
+               endif
+               if (dist_j /= 0) then
+                  grad_lat(i,j) = grad_lat(i,j) / dist_j
+               else
+                  grad_lat(i,j) = 0.
+               endif
+              
+!              correct skale
+!              -------------
+               ABSold = SQRT(grad_i**2 + grad_j**2)
+               ABSnew = SQRT(grad_lon(i,j)**2 + grad_lat(i,j)**2)
+               IF (ABSnew > 1.E-10) THEN
+C                  grad_lon(i,j) = grad_lon(i,j)*ABSold/ABSnew
+                  grad_lon(i,j) = grad_lon(i,j)
+               ELSE
+                  grad_lon(i,j) = 0.0
+               ENDIF
+
+!              test orthogonality
+!              ------------------
+               IF ((dlon_i*dlon_j+dlat_j*dlat_i) > 0.1) THEN
+                  print*, 'ORTHOGONAL? ', i, j,
+     $                    (dlon_i*dlon_j+dlat_j*dlat_i)
+               ENDIF
+
+            ELSE
+           
+               grad_lat(i,j) = 0.
+               grad_lon(i,j) = 0. 
+            
+            ENDIF
+
+         ENDDO
+      ENDDO
+ 
+      RETURN
+
+      END SUBROUTINE gradient
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/gradient_bicubic.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/gradient_bicubic.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/gradient_bicubic.f	(revision 1677)
@@ -0,0 +1,238 @@
+      subroutine gradient_bicubic(NX1, NY1, src_array, sou_mask,
+     $                            src_latitudes, src_longitudes, 
+     $                            id_nosper,
+     $                            gradient_i, gradient_j, gradient_ij)
+
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *gradient_bicubic*  - calculate gradients for bicubic remapping
+C
+C     Purpose:
+C     -------
+C     Calculation of gradients for bicubic interpolation. In contrast to
+C     the gradients of conservative remapping, these gradients are    
+C     calculated with respect to grid rows and grid lines.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *gradient_bicubic*(NX1, NY1, src_array, sou_mask,
+C                                  src_latitudes, src_longitudes, 
+C                                  gradient_i, gradient_j, gradient_ij)
+C
+C     Input:
+C     -----
+C          NX1            : grid dimension in x-direction (integer)
+C          NY1            : grid dimension in y-direction (integer)
+C          src_array      : array on source grid (real 2D)
+C          sou_mask       : source grid mask (integer 2D)
+C          src_latitudes  : latitudes on source grid (real 2D)
+C          src_longitudes : longitudes on source grid (real 2D)
+C          id_nosper      : number of overlapping points for source grid
+C
+C     Output:
+C     ------
+C          gradient_i     : gradient in i-direction (real 2D)
+C          gradient_j     : gradient in j-direction (real 2D)
+C          gradient_ij    : gradient in ij-direction (real 2D)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       V. Gayler      2002/04/05  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      USE constants
+      USE kinds_mod
+
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!     INTENT(IN)
+!-----------------------------------------------------------------------
+      INTEGER (int_kind), INTENT(IN) ::
+     $     NX1, NY1,            ! source grid dimensiones
+     $    id_nosper             ! nbr of overlapping grid points
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     src_array            ! array on source grid
+
+      INTEGER (int_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     sou_mask             ! source grid mask
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(IN) ::
+     $     src_latitudes,       ! source grid latitudes
+     $     src_longitudes       ! source grid longitudes
+
+!-----------------------------------------------------------------------
+!     INTENT(OUT)
+!-----------------------------------------------------------------------
+      REAL (kind = real_kind), DIMENSION(NX1,NY1), INTENT(OUT) ::
+     $     gradient_i,          ! gradient in i-direction (real 2D)
+     $     gradient_j,          ! gradient in j-direction (real 2D)
+     $     gradient_ij          ! gradient in ij-direction (real 2D)
+
+!-----------------------------------------------------------------------
+!     LOCAL VARIABLES
+!-----------------------------------------------------------------------
+      INTEGER (int_kind) ::
+     $     i, j,                ! looping indicees
+     $     ip1, jp1, im1, jm1
+     
+      REAL (kind = real_kind) ::
+     $     di, dj,              ! factor depending on grid cell distance
+     $     gradient_ij1,        ! gradient needed to calculate gradient_ij
+     $     gradient_ij2         ! gradient needed to calculate gradient_ij
+
+      REAL (kind = real_kind), DIMENSION(NX1,NY1) ::
+     $     src_lon,             ! source grid longitudes [radiants]
+     $     src_lat,             ! source grid latitudes [radiants]
+     $     pi180                ! conversion factor: deg -> rad
+
+      INTEGER (int_kind) ::  il_maskval= 0_int_kind
+
+!-----------------------------------------------------------------------
+
+!     Transformation from degree to radiant
+!     -------------------------------------
+      pi180 = 1.74532925199432957692e-2 ! =PI/180
+
+      src_lon = src_longitudes * pi180
+      src_lat = src_latitudes * pi180
+
+!     Initialization
+!     --------------
+      gradient_i  = 0.
+      gradient_j  = 0. 
+      gradient_ij = 0. 
+
+!     calculate gradients
+!     -------------------
+      DO i = 1, NX1
+         DO j = 1, NY1
+                   
+            IF (sou_mask (i,j) /= il_maskval) THEN
+
+               di = half
+               dj = half
+
+               ip1 = i + 1
+               im1 = i - 1
+               IF (i == NX1) ip1 = 1 + id_nosper   ! the 0-meridian
+               IF (i == 1 )  im1 = NX1 - id_nosper
+               jp1 = j + 1
+               jm1 = j - 1
+               IF (j == NY1) THEN ! treatment of the last..
+                  jp1 = NY1 
+                  dj = one 
+               ENDIF   
+               IF (j == 1 ) THEN  ! .. and the first grid-row
+                  jm1 = 1
+                  dj = one
+               ENDIF
+
+
+!              gradient i
+!              ----------
+               IF (sou_mask(ip1,j) /= il_maskval .OR.
+     $             sou_mask(im1,j) /= il_maskval) THEN
+                  IF (sou_mask(ip1,j) == il_maskval) THEN
+                     ip1 = i
+                     di = one
+                  ELSE IF (sou_mask(im1,j) == il_maskval) THEN
+                     im1 = i
+                     di = one
+                  ENDIF
+                  gradient_i(i,j) =
+     $                        di * (src_array(ip1,j) - src_array(im1,j))
+               ENDIF
+
+!              gradient j
+!              ----------
+               IF (sou_mask(i,jp1) /= il_maskval .OR.
+     $             sou_mask(i,jm1) /= il_maskval) THEN
+                  IF (sou_mask(i,jp1) == il_maskval) THEN
+                     jp1 = j
+                     dj = one
+                  ELSE IF (sou_mask(i,jm1) == il_maskval) THEN
+                     jm1 = j
+                     dj = one
+                  ENDIF
+                  gradient_j(i,j) = 
+     $                        dj * (src_array(i,jp1) - src_array(i,jm1))
+               ENDIF
+!
+!              gradient ij
+!              -----------
+               di = half
+               dj = half
+               ip1 = i + 1
+               im1 = i - 1
+               IF (i == NX1) ip1 = 1 + id_nosper   ! the 0-meridian
+               IF (i == 1 )  im1 = NX1 - id_nosper
+               jp1 = j + 1
+               jm1 = j - 1
+               IF (j == NY1) THEN ! treatment of the last..
+                  jp1 = NY1 
+                  dj = one 
+               ENDIF   
+               IF (j == 1 ) THEN  ! .. and the first grid-row
+                  jm1 = 1
+                  dj = one
+               ENDIF
+
+               gradient_ij1 = zero
+               IF (sou_mask(ip1,jp1) /= il_maskval .OR.
+     $             sou_mask(im1,jp1) /= il_maskval) THEN
+                  IF (sou_mask(ip1,jp1) == il_maskval .AND.
+     $                sou_mask(i,jp1) /= il_maskval) THEN
+                     ip1 = i
+                     di = one
+                  ELSE IF (sou_mask(im1,jp1) == il_maskval .AND.
+     $                     sou_mask(i,jp1) /= il_maskval) THEN
+                     im1 = i
+                     di = one
+                  ELSE
+                     di = zero
+                  ENDIF
+                  gradient_ij1 =
+     $                    di * (src_array(ip1,jp1) - src_array(im1,jp1))
+               ENDIF
+
+               di = half
+               ip1 = i + 1
+               im1 = i - 1
+               IF (i == NX1) ip1 = 1 + id_nosper  ! the 0-meridian
+               IF (i == 1 )  im1 = NX1 - id_nosper
+ 
+               gradient_ij2 = zero
+               IF (sou_mask(ip1,jm1) /= il_maskval .OR.
+     $             sou_mask(im1,jm1) /= il_maskval) THEN
+                  IF (sou_mask(ip1,jm1) == il_maskval .AND.
+     $                sou_mask(i,jm1) /= il_maskval) THEN
+                     ip1 = i
+                     di = one
+                  ELSE IF (sou_mask(im1,jm1) == il_maskval .AND.
+     $                     sou_mask(i,jm1) /= il_maskval) THEN
+                     im1 = i
+                     di = one
+                  ELSE
+                     di = zero
+                  ENDIF
+                  gradient_ij2 =
+     $                    di * (src_array(ip1,jm1) - src_array(im1,jm1))
+               ENDIF
+
+               IF (gradient_ij1 /= zero .AND. gradient_ij2 /= zero) THEN
+                  gradient_ij(i,j) = dj * (gradient_ij1 - gradient_ij2)
+               ENDIF
+            ENDIF
+            
+         ENDDO
+      ENDDO
+      RETURN
+
+      END SUBROUTINE gradient_bicubic
Index: CPL/oasis3/trunk/src/lib/scrip/src/grids.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/grids.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/grids.f	(revision 1677)
@@ -0,0 +1,771 @@
+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,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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
+
+      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)
+
+!-----------------------------------------------------------------------
+!
+!     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 
+
+      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
+
+!-----------------------------------------------------------------------
+!
+!     allocate grid coordinates/masks and read data
+!
+!-----------------------------------------------------------------------
+      
+      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(stdout,*) '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(stdout,*) '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(stdout,*) 
+     &  '|  Using reduced bins to restrict search. Reduced grids with'
+        write(stdout,*) 
+     &  '| 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
+ 
+!-----------------------------------------------------------------------
+
+      end subroutine grid_init
+
+!***********************************************************************
+
+      subroutine free_grids
+
+!-----------------------------------------------------------------------
+!
+!     subroutine to deallocate allocated arrays
+!
+!----------------------------------------------------------------------- 
+
+      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
+
+!-----------------------------------------------------------------------
+
+      end subroutine free_grids
+
+!***********************************************************************
+
+      end module grids
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/iounits.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/iounits.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/iounits.f	(revision 1677)
@@ -0,0 +1,154 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module is a dynamic I/O unit manager.  It keeps track of
+!     which units are in use and reserves units for stdin, stdout, and
+!     stderr.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: iounits.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 iounits
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod   ! defines data types
+
+      implicit none
+
+!-----------------------------------------------------------------------
+
+      logical (kind=log_kind), dimension(99), save ::
+     &    unit_free   ! flags to determine whether unit is free for use
+
+      integer (kind=int_kind), parameter ::
+     &    stdin  = 5, ! reserves unit for standard input
+     &    stdout = 6, ! reserves unit for standard output
+     &    stderr = 6  ! reserves unit for standard error
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine get_unit(iunit)
+
+!-----------------------------------------------------------------------
+!
+!     This routine returns the next available I/O unit number.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(out) ::
+     &     iunit   ! next free I/O unit
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n
+
+      logical (kind=log_kind), save :: first_call = .true.
+
+!-----------------------------------------------------------------------
+!
+!     if this is the first call, reserve stdout, stdin and stderr
+!
+!-----------------------------------------------------------------------
+
+      if (first_call) then
+        unit_free = .true.
+        unit_free(stdin)  = .false.
+        unit_free(stdout) = .false.
+        unit_free(stderr) = .false.
+        first_call = .false.
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     search for next available unit
+!
+!-----------------------------------------------------------------------
+
+      srch_unit: do n=1,99
+        if (unit_free(n)) then
+          iunit = n
+          unit_free(n) = .false.
+          exit srch_unit
+        endif
+      end do srch_unit
+
+!-----------------------------------------------------------------------
+
+      end subroutine get_unit
+
+!***********************************************************************
+
+      subroutine release_unit(iunit)
+
+!-----------------------------------------------------------------------
+!
+!     This routine releases the specified unit and closes the file.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &     iunit   ! I/O unit to release
+
+!-----------------------------------------------------------------------
+!
+!     closes I/O unit and declares it free
+!
+!-----------------------------------------------------------------------
+
+      unit_free(iunit) = .true.
+      close(iunit)
+
+!-----------------------------------------------------------------------
+
+      end subroutine release_unit
+
+!***********************************************************************
+
+      end module iounits
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/kinds_mod.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/kinds_mod.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/kinds_mod.f	(revision 1677)
@@ -0,0 +1,53 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module defines the F90 kind parameter for common data types.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: kinds_mod.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 kinds_mod
+      USE mod_kinds_oasis
+
+!-----------------------------------------------------------------------
+
+      implicit none
+      save
+
+!-----------------------------------------------------------------------
+
+      integer(kind=ip_intwp_p), parameter :: char_len  = 80
+      integer(kind=ip_intwp_p), parameter :: int_kind  = ip_intwp_p
+      integer(kind=ip_intwp_p), parameter :: log_kind  = kind(.true.)
+      integer(kind=ip_intwp_p), parameter :: real_kind = ip_realwp_p
+      integer(kind=ip_intwp_p), parameter :: dbl_kind  = ip_realwp_p
+!-----------------------------------------------------------------------
+
+      end module kinds_mod
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/netcdf.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/netcdf.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/netcdf.f	(revision 1677)
@@ -0,0 +1,79 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module contains the netCDF include file and a netcdf error
+!     handling routine.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: netcdf.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 netcdf_mod
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod
+      use constants
+
+      implicit none
+
+      include 'netcdf.inc'
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine netcdf_error_handler(istat)
+
+!-----------------------------------------------------------------------
+!
+!     This routine provides a simple interface to netCDF error message
+!     routine.
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) :: 
+     &    istat   ! integer status returned by netCDF function call
+
+!-----------------------------------------------------------------------
+
+      if (istat /= NF_NOERR) then
+        print *,'Error in netCDF: ',nf_strerror(istat)
+        stop
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine netcdf_error_handler
+
+!***********************************************************************
+
+      end module netcdf_mod
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic.f	(revision 1677)
@@ -0,0 +1,754 @@
+C****
+C               *****************************
+C               * OASIS MODULE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** remap_bilinear - calculate bilinear remapping
+C
+C     Purpose:
+C     -------
+C     Adaptation of SCRIP 1.4 remap_bicubic module to calculate 
+C     bicubic remapping.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *remap_bicub**
+C
+C     Input:
+C     -----
+C
+C     Output:
+C     ------
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       S. Valcke      2002/09     Treatment for masked point
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for performing an 
+!     bicubic interpolation.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_bicubic.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 remap_bicubic
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid info
+      use remap_vars    ! module containing remap info
+      USE mod_unit
+      USE mod_printing
+
+      implicit NONE
+
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), parameter ::
+     &    max_iter = 100   ! max iteration count for i,j iteration
+
+      real (kind=dbl_kind), parameter ::
+     &     converge = 1.e-10_dbl_kind  ! convergence criterion
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_bicub (lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the weights for a bicubic interpolation.
+!
+!-----------------------------------------------------------------------
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n,icount,i, 
+     &     dst_add,        ! destination address
+     &     iter,           ! iteration counter
+     &     nmap            ! index of current map being computed
+
+      integer (kind=int_kind), dimension(4) :: 
+     &     src_add         ! address for the four source points
+
+      real (kind=dbl_kind), dimension(4)  ::
+     &     src_lats,       ! latitudes  of four  corners
+     &     src_lons        ! longitudes of four  corners
+
+      real (kind=dbl_kind), dimension(4,4)  ::
+     &     wgts            ! bicubic weights for four corners
+
+      real (kind=dbl_kind) ::
+     &     plat, plon,       ! lat/lon coords of destination point
+     &     iguess, jguess,   ! current guess for bicubic coordinate
+     &     deli, delj,       ! corrections to i,j
+     &     dth1, dth2, dth3, ! some latitude  differences
+     &     dph1, dph2, dph3, ! some longitude differences
+     &     dthp, dphp,       ! difference between point and sw corner
+     &     mat1, mat2, mat3, mat4, ! matrix elements
+     &     determinant,      ! matrix determinant
+     &     sum_wgts         ! sum of weights for normalization
+
+      real (kind=dbl_kind) ::  
+     &      coslat_dst, sinlat_dst, coslon_dst, sinlon_dst,
+     &      dist_min, distance, ! for computing dist-weighted avg
+     &      src_latsnn
+
+      integer (kind=int_kind) :: min_add, max_add, srch_add, src_addnn
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid1 to grid2
+!
+!-----------------------------------------------------------------------
+
+      nmap = 1
+      if (grid1_rank /= 2) then
+        stop 'Can not do bicubic interpolation when grid_rank /= 2'
+      endif
+
+      !***
+      !*** loop over destination grid 
+      !***
+      
+      grid_loop1: do dst_add = 1, grid2_size
+
+        if (.not. grid2_mask(dst_add)) cycle grid_loop1
+
+        plat = grid2_center_lat(dst_add)
+        plon = grid2_center_lon(dst_add)
+
+        !***
+        !*** find nearest square of grid points on source grid
+        !***
+
+        call grid_search_bicub(src_add, src_lats, src_lons,
+     &                         min_add, max_add,
+     &                         plat, plon, grid1_dims,
+     &                         grid1_center_lat, grid1_center_lon,
+     &                         grid1_bound_box, bin_addr1, 
+     &                         lextrapdone)
+
+        if (src_add(1) > 0) then
+
+          !***
+          !*** if the 4 surrounding points have been found and are 
+          !*** non-masked, do bicubic interpolation
+          !***
+
+          grid2_frac(dst_add) = one
+
+          dth1 = src_lats(2) - src_lats(1)
+          dth2 = src_lats(4) - src_lats(1)
+          dth3 = src_lats(3) - src_lats(2) - dth2
+
+          dph1 = src_lons(2) - src_lons(1)
+          dph2 = src_lons(4) - src_lons(1)
+          dph3 = src_lons(3) - src_lons(2)
+
+          if (dph1 >  three*pih) dph1 = dph1 - pi2
+          if (dph2 >  three*pih) dph2 = dph2 - pi2
+          if (dph3 >  three*pih) dph3 = dph3 - pi2
+          if (dph1 < -three*pih) dph1 = dph1 + pi2
+          if (dph2 < -three*pih) dph2 = dph2 + pi2
+          if (dph3 < -three*pih) dph3 = dph3 + pi2
+
+          dph3 = dph3 - dph2
+
+          iguess = half
+          jguess = half
+
+          iter_loop1: do iter=1,max_iter
+
+            dthp = plat - src_lats(1) - dth1*iguess -
+     &                    dth2*jguess - dth3*iguess*jguess
+            dphp = plon - src_lons(1)
+
+            if (dphp >  three*pih) dphp = dphp - pi2
+            if (dphp < -three*pih) dphp = dphp + pi2
+
+            dphp = dphp - dph1*iguess - dph2*jguess - 
+     &                    dph3*iguess*jguess
+
+            mat1 = dth1 + dth3*jguess
+            mat2 = dth2 + dth3*iguess
+            mat3 = dph1 + dph3*jguess
+            mat4 = dph2 + dph3*iguess
+
+            determinant = mat1*mat4 - mat2*mat3
+
+            deli = (dthp*mat4 - mat2*dphp)/determinant
+            delj = (mat1*dphp - dthp*mat3)/determinant
+
+            if (abs(deli) < converge .and. 
+     &          abs(delj) < converge) exit iter_loop1
+
+            iguess = iguess + deli
+            jguess = jguess + delj
+
+          end do iter_loop1
+
+          if (iter <= max_iter) then
+
+            !***
+            !*** successfully found i,j - compute weights
+            !***
+
+            wgts(1,1) = (one - jguess**2*(three-two*jguess))*
+     &                  (one - iguess**2*(three-two*iguess))
+            wgts(1,2) = (one - jguess**2*(three-two*jguess))*
+     &                         iguess**2*(three-two*iguess)
+            wgts(1,3) =        jguess**2*(three-two*jguess)*
+     &                         iguess**2*(three-two*iguess)
+            wgts(1,4) =        jguess**2*(three-two*jguess)*
+     &                  (one - iguess**2*(three-two*iguess))
+            wgts(2,1) = (one - jguess**2*(three-two*jguess))*
+     &                         iguess*(iguess-one)**2
+            wgts(2,2) = (one - jguess**2*(three-two*jguess))*
+     &                         iguess**2*(iguess-one)
+            wgts(2,3) =        jguess**2*(three-two*jguess)*
+     &                         iguess**2*(iguess-one)
+            wgts(2,4) =        jguess**2*(three-two*jguess)*
+     &                         iguess*(iguess-one)**2
+            wgts(3,1) =        jguess*(jguess-one)**2*
+     &                  (one - iguess**2*(three-two*iguess))
+            wgts(3,2) =        jguess*(jguess-one)**2*
+     &                         iguess**2*(three-two*iguess)
+            wgts(3,3) =        jguess**2*(jguess-one)*
+     &                         iguess**2*(three-two*iguess)
+            wgts(3,4) =        jguess**2*(jguess-one)*
+     &                  (one - iguess**2*(three-two*iguess))
+            wgts(4,1) =        iguess*(iguess-one)**2*
+     &                         jguess*(jguess-one)**2
+            wgts(4,2) =        iguess**2*(iguess-one)*
+     &                         jguess*(jguess-one)**2
+            wgts(4,3) =        iguess**2*(iguess-one)*
+     &                         jguess**2*(jguess-one)
+            wgts(4,4) =        iguess*(iguess-one)**2*
+     &                         jguess**2*(jguess-one)
+
+            call store_link_bicub(dst_add, src_add, wgts, nmap)
+
+          else
+            stop 'Iteration for i,j exceed max iteration count'
+          endif
+
+        else if (src_add(1) < 0) THEN
+
+          !***
+          !*** Search for bicubic failed or at least one of the 4
+          !*** neighbours was masked. Do distance-weighted average using
+          !*** the non-masked points among the 4 closest ones. 
+          !***
+
+
+          IF (nlogprt .eq. 2) then
+              WRITE(nulou,*) ' '
+              WRITE(nulou,*) 
+     &  'WARNING: Cannot make bicubic interpolation for target point'
+     &            ,dst_add
+              WRITE(nulou,*) 
+     &    'Using non-masked points among 4 nearest neighbors.'
+              WRITE(nulou,*) ' '
+          ENDIF
+
+          !***
+          !*** Find the 4 closest points
+          !***
+
+          coslat_dst = cos(plat)
+          sinlat_dst = sin(plat)
+          coslon_dst = cos(plon)
+          sinlon_dst = sin(plon)
+          src_add = 0
+          dist_min = bignum
+          src_lats = bignum
+          do srch_add = min_add,max_add
+            distance=acos(coslat_dst*cos(grid1_center_lat(srch_add))*
+     &          (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &          sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &          sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+            if (distance < dist_min) then
+                sort_loop: do n=1,4
+                if (distance < src_lats(n)) then
+                    do i=4,n+1,-1
+                      src_add (i) = src_add (i-1)
+                      src_lats(i) = src_lats(i-1)
+                    end do
+                    src_add (n) = srch_add
+                    src_lats(n) = distance
+                    dist_min = src_lats(4)
+                    exit sort_loop
+                endif
+                end do sort_loop
+            endif
+          end do
+
+          src_lons = one/(src_lats + tiny)
+          distance = sum(src_lons)
+          src_lats = src_lons/distance
+
+          !***
+          !*** Among 4 closest points, keep only the non-masked ones
+          !***
+
+          icount = 0
+          do n=1,4
+            if (grid1_mask(src_add(n)) .or.
+     &          (.not. grid1_mask(src_add(n)) .and. lextrapdone)) then
+                icount = icount + 1
+            else
+                src_lats(n) = zero
+            endif
+          end do
+
+          if (icount > 0) then
+              !*** renormalize weights
+              sum_wgts = sum(src_lats)
+              wgts(1,1) = src_lats(1)/sum_wgts
+              wgts(1,2) = src_lats(2)/sum_wgts
+              wgts(1,3) = src_lats(3)/sum_wgts
+              wgts(1,4) = src_lats(4)/sum_wgts
+              wgts(2,:) = 0.
+              wgts(3,:) = 0.
+              wgts(4,:) = 0.
+
+              grid2_frac(dst_add) = one
+              call store_link_bicub(dst_add, src_add, wgts, nmap)
+          ELSE
+              WRITE(nulou,*) '  '
+              WRITE(nulou,*) 
+     &       'All 4 surrounding source grid points are masked'
+              WRITE(nulou,*) 'for target point ',dst_add
+              WRITE(nulou,*) 'with longitude and latitude', plon, plat
+              WRITE(nulou,*) 'Using the nearest non-masked neighbour.' 
+              WRITE(nulou,*) '  '
+
+              src_latsnn = bignum
+              do srch_add = min_add,max_add
+                if (grid1_mask(srch_add) .or.
+     &          (.not. grid1_mask(srch_add) .and. lextrapdone)) then
+                    distance=acos(coslat_dst
+     &                  *cos(grid1_center_lat(srch_add))*
+     &                  (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &                  sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &                  sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+                    if (distance < src_latsnn) then
+                        src_addnn = srch_add
+                        src_latsnn = distance
+                    endif
+                endif
+              end DO
+
+              WRITE(nulou,*) 
+     &        'Nearest non masked neighbour is source point ',src_addnn
+              WRITE(nulou,*) 'with longitude and latitude',
+     &        grid1_center_lon(src_addnn), grid1_center_lat(src_addnn) 
+              WRITE(nulou,*) '  '
+
+              wgts(1,1) = 1.
+              wgts(1,2:4) = 0.
+              wgts(2,:) = 0.
+              wgts(3,:) = 0.
+              wgts(4,:) = 0.
+              src_add(1) = src_addnn
+              src_add(2) = 0
+              src_add(3) = 0
+              src_add(4) = 0
+
+              grid2_frac(dst_add) = one
+              call store_link_bicub(dst_add, src_add, wgts, nmap)
+
+          ENDIF
+      ENDIF
+      end do grid_loop1
+
+      end subroutine remap_bicub
+
+!***********************************************************************
+
+      subroutine grid_search_bicub(src_add, src_lats, src_lons, 
+     &                             min_add, max_add,
+     &                             plat, plon, src_grid_dims,
+     &                             src_center_lat, src_center_lon,
+     &                             src_bound_box,
+     &                             src_bin_add, lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the location of the search point plat, plon
+!     in the source grid and returns the corners needed for a bicubic
+!     interpolation.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(4), intent(out) ::
+     &        src_add  ! address of each corner point enclosing P
+
+      real (kind=dbl_kind), dimension(4), intent(out) ::
+     &        src_lats, ! latitudes  of the four corner points
+     &        src_lons  ! longitudes of the four corner points
+
+      integer (kind=int_kind) :: min_add, max_add
+    
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), intent(in) ::
+     &        plat,   ! latitude  of the search point
+     &        plon    ! longitude of the search point
+
+      integer (kind=int_kind), dimension(2), intent(in) ::
+     &        src_grid_dims  ! size of each src grid dimension
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        src_center_lat, ! latitude  of each src grid center 
+     &        src_center_lon  ! longitude of each src grid center
+
+      real (kind=dbl_kind), dimension(:,:), intent(in) ::
+     &        src_bound_box   ! bounding box for src grid search
+
+      integer (kind=int_kind), dimension(:,:), intent(in) ::
+     &        src_bin_add    ! search bins for restricting
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, next_n, srch_add, ni,  ! dummy indices
+     &    nx, ny, ntotmask,           ! dimensions of src grid
+     &    i, j, jp1, ip1, n_add, e_add, ne_add  ! addresses
+
+      real (kind=dbl_kind) ::  ! vectors for cross-product check
+     &      vec1_lat, vec1_lon,
+     &      vec2_lat, vec2_lon, cross_product, cross_product_last
+
+!-----------------------------------------------------------------------
+!
+!     restrict search first using search bins. 
+!
+!-----------------------------------------------------------------------
+
+      src_add = 0
+
+      min_add = size(src_center_lat)
+      max_add = 1
+      do n=1,num_srch_bins
+        if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and.
+     &      plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then
+          min_add = min(min_add, src_bin_add(1,n))
+          max_add = max(max_add, src_bin_add(2,n))
+        endif
+      end do
+ 
+!-----------------------------------------------------------------------
+!
+!     now perform a more detailed search 
+!
+!-----------------------------------------------------------------------
+
+      nx = src_grid_dims(1)
+      ny = src_grid_dims(2)
+
+      srch_loop: do srch_add = min_add,max_add
+
+        !*** first check bounding box
+
+        if (plat <= src_bound_box(2,srch_add) .and. 
+     &    plat >= src_bound_box(1,srch_add) .and.
+     &    plon <= src_bound_box(4,srch_add) .and. 
+     &    plon >= src_bound_box(3,srch_add)) then
+
+          !***
+          !*** we are within bounding box so get really serious
+          !***
+
+          !*** find N,S and NE points to this grid point
+
+          j = (srch_add - 1)/nx +1
+          i = srch_add - (j-1)*nx
+          
+          !*** find ip1
+          !*** Note: I do not want to take into account the number
+          !*** of overlapping grid points, as the underlying cell
+          !*** will be found in all cases if the grid overlaps.
+
+          if (i < nx) then
+              ip1 = i + 1
+          else
+              ip1 = 1
+          endif
+
+          if (j < ny) then
+              jp1 = j+1
+          else
+              jp1 = 1
+          endif
+
+          n_add = (jp1 - 1)*nx + i
+          e_add = (j - 1)*nx + ip1
+          ne_add = (jp1 - 1)*nx + ip1
+
+          src_lats(1) = src_center_lat(srch_add)
+          src_lats(2) = src_center_lat(e_add)
+          src_lats(3) = src_center_lat(ne_add)
+          src_lats(4) = src_center_lat(n_add)
+
+          src_lons(1) = src_center_lon(srch_add)
+          src_lons(2) = src_center_lon(e_add)
+          src_lons(3) = src_center_lon(ne_add)
+          src_lons(4) = src_center_lon(n_add)
+
+          !***
+          !*** for consistency, we must make sure all lons are in
+          !*** same 2pi interval
+          !***
+
+          vec1_lon = src_lons(1) - plon
+          if (vec1_lon > pi) then
+              src_lons(1) = src_lons(1) - pi2
+          else if (vec1_lon < -pi) then
+              src_lons(1) = src_lons(1) + pi2
+          endif
+          do n=2,4
+            vec1_lon = src_lons(n) - src_lons(1)
+            if (vec1_lon > pi) then
+                src_lons(n) = src_lons(n) - pi2
+            else if (vec1_lon < -pi) then
+                src_lons(n) = src_lons(n) + pi2
+            endif
+          end do
+
+          corner_loop: do n=1,4
+            next_n = MOD(n,4) + 1
+
+            !***
+            !*** here we take the cross product of the vector making 
+            !*** up each box side with the vector formed by the vertex
+            !*** and search point.  if all the cross products are 
+            !*** same sign, the point is contained in the box.
+            !***
+
+            vec1_lat = src_lats(next_n) - src_lats(n)
+            vec1_lon = src_lons(next_n) - src_lons(n)
+            vec2_lat = plat - src_lats(n)
+            vec2_lon = plon - src_lons(n)
+
+            !***
+            !*** check for 0,2pi crossings
+            !***
+
+            if (vec1_lon >  three*pih) then
+                vec1_lon = vec1_lon - pi2
+            else if (vec1_lon < -three*pih) then
+                vec1_lon = vec1_lon + pi2
+            endif
+            if (vec2_lon >  three*pih) then
+                vec2_lon = vec2_lon - pi2
+            else if (vec2_lon < -three*pih) then
+                vec2_lon = vec2_lon + pi2
+            endif
+
+            cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat
+
+            !***
+            !*** if cross product is less than zero, this cell
+            !*** doesn't work
+            !***
+
+            if (n == 1) cross_product_last = cross_product
+            if (cross_product*cross_product_last < zero) then
+                exit corner_loop
+            else
+                cross_product_last = cross_product
+            endif
+
+          end do corner_loop
+
+          !***
+          !*** if cross products all positive, we found the location
+          !***
+
+          if (n > 4) then
+              src_add(1) = srch_add
+              src_add(2) = e_add
+              src_add(3) = ne_add
+              src_add(4) = n_add
+              
+              ! Check if one point is masked; IF so, nearest-neighbour
+              ! interpolation will be used
+  
+              ntotmask = 0
+              do ni=1,4
+                if (.not. grid1_mask(src_add(ni)).and. 
+     &              .not. lextrapdone) 
+     &              ntotmask = ntotmask + 1 
+              end DO
+              IF (ntotmask .gt. 0) src_add(1) = -src_add(1)  
+      
+              return
+          endif
+
+          !***
+          !*** otherwise move on to next cell
+          !***
+
+      endif                     !bounding box check
+      end do srch_loop
+
+      !***
+      !*** if no cell found, point is likely either in a box that straddles
+      !*** either pole or is outside the grid. Put src_add = -1 so that
+      !*** distance-weighted average of the 4 non-masked closest points
+      !*** is done in calling routine.
+  
+      src_add = -1
+
+!-----------------------------------------------------------------------
+
+      end subroutine grid_search_bicub 
+
+!***********************************************************************
+
+      subroutine store_link_bicub(dst_add, src_add, weights, nmap)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for four links 
+!     associated with one destination point in the appropriate address 
+!     and weight arrays and resizes those arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        dst_add,  ! address on destination grid
+     &        nmap      ! identifies which direction for mapping
+
+      integer (kind=int_kind), dimension(4), intent(in) ::
+     &        src_add   ! addresses on source grid
+
+      real (kind=dbl_kind), dimension(4,4), intent(in) ::
+     &        weights ! array of remapping weights for these links
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, ! dummy index
+     &       num_links_old          ! placeholder for old link number
+
+!-----------------------------------------------------------------------
+!
+!     increment number of links and check to see if remap arrays need
+!     to be increased to accomodate the new link.  then store the
+!     link.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        num_links_old  = num_links_map1
+        num_links_map1 = num_links_old + 4
+
+        if (num_links_map1 > max_links_map1) 
+     &     call resize_remap_vars(1,resize_increment)
+
+        do n=1,4
+          grid1_add_map1(num_links_old+n) = src_add(n)
+          grid2_add_map1(num_links_old+n) = dst_add
+          wts_map1    (:,num_links_old+n) = weights(:,n)
+        end do
+
+      case(2)
+
+        num_links_old  = num_links_map2
+        num_links_map2 = num_links_old + 4
+
+        if (num_links_map2 > max_links_map2) 
+     &     call resize_remap_vars(2,resize_increment)
+
+        do n=1,4
+          grid1_add_map2(num_links_old+n) = dst_add
+          grid2_add_map2(num_links_old+n) = src_add(n)
+          wts_map2    (:,num_links_old+n) = weights(:,n)
+        end do
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_bicub
+
+!***********************************************************************
+
+      end module remap_bicubic
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic_reduced.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic_reduced.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_bicubic_reduced.F90	(revision 1677)
@@ -0,0 +1,1077 @@
+MODULE remap_bicubic_reduced
+
+!-----------------------------------------------------------------------
+! BOP
+!
+! !MODULE: remap_bicubic_reduced
+! 
+! !USES:
+  USE mod_kinds_oasis       ! defines common data types      
+  USE constants             ! defines common constants      
+  USE grids                 ! module containing grid info
+  USE remap_vars            ! module containing remap info
+
+! !PUBLIC TYPES:
+  USE mod_unit
+  IMPLICIT NONE  
+! !PUBLIC MEMBER FUNCTIONS:
+!  
+! !PUBLIC DATA MEMBERS:
+ 
+! !DESCRIPTION:
+!  This routine computes the weights for a bicubic interpolation
+!  with a reduced grid. Computes mappings from grid1 to grid2.
+!
+! !REVISION HISTORY:
+!  2002.10.21  J.Ghattas  created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------
+  
+
+
+CONTAINS
+  
+!***********************************************************************
+  
+    
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE:  remap_bicub_reduced
+!
+! !INTERFACE:
+
+  SUBROUTINE remap_bicub_reduced(ld_extrapdone)
+      
+! !USES:
+    
+! !RETURN VALUE:
+    
+! !PARAMETERS:
+
+    LOGICAL, INTENT(in) :: &
+       ld_extrapdone              ! logical, true if EXTRAP done on field
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4,4) :: &
+       ila_src_add                ! address for source points non-masked  
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4) :: &
+       ila_nbr_found              ! nrb of points found on each latitude
+    
+    INTEGER (KIND=ip_intwp_p) :: &
+       ib_i, &                    ! iter index
+       ib_dst_add, &              ! destination address, target point
+       il_count, &                ! nbr of latitudes with found points   
+       il_min, il_max, bin        ! begin and end for distances calculation
+    
+    REAL (KIND=ip_realwp_p), DIMENSION(4,4) :: &
+       rla_src_lons, &            ! longitudes for the points 'ila_src_add'
+       rla_weight, &              ! bicubic weights for the points 'ila_src_add'
+       rla_wght_lon               ! temp. weights
+    
+    REAL (KIND=ip_realwp_p), DIMENSION(4) :: &
+       rla_src_lats, &            ! latitudes for the points 'ila_src_add'
+       rla_lats_temp, &           ! temp. latitudes
+       rla_wght_lat, rla_wght_temp! temp. weights
+    
+    REAL (KIND=ip_realwp_p) :: &
+       rl_plat, rl_plon         ! latitude and longitude for destination address
+    
+    REAL (KIND=ip_realwp_p) :: &     ! variables for distances calculation
+       rl_coslat_dst, rl_sinlat_dst, &
+       rl_coslon_dst, rl_sinlon_dst, &
+       rl_distance           
+
+    REAL (KIND=ip_realwp_p), DIMENSION(2) :: &
+       rla_dist                   ! lat distances to point cible     
+
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4) :: &
+       ila_add_dist               ! temporary addr. for distances       
+
+    LOGICAL :: ll_linear          ! flag
+
+    
+! !DESCRIPTION:
+!  This routine computes the weights for a bicubic interpolation
+!  with a reduced grid. Computes mappings from grid1 to grid2.     
+! 
+! !REVISION HISTORY:
+!  2002.10.21  J.Ghattas   created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------
+   
+
+    !
+    !  Loop over destination grid     
+    !
+
+    DO ib_dst_add = 1, grid2_size ! for each target point
+      ll_linear=.false.
+      IF (.NOT. grid2_mask(ib_dst_add)) THEN
+	  CYCLE      ! target point is masked
+      END IF
+      
+      rl_plat = grid2_center_lat(ib_dst_add)
+      rl_plon = grid2_center_lon(ib_dst_add)
+      
+
+      !
+      !   Search for non-masked points among the closest 16 points 
+      !   on source grid (grid1)
+      !
+
+      CALL grid_search_16_points(ila_src_add,   rla_src_lats, rla_src_lons,&
+	                         ila_nbr_found, bin,          rl_plat, &
+				 rl_plon,       ld_extrapdone)
+    
+		      
+      !
+      ! If there is no point found, search the neaerst 
+      ! non-masked point
+      !
+
+      IF (SUM(ila_nbr_found)==0) THEN
+	  WRITE(nulou,*) '  '
+	  WRITE(nulou,*) &
+	     'All 16 surrounding source grid points are masked'
+	  WRITE(nulou,*) 'for target point ',ib_dst_add
+	  WRITE(nulou,*) 'with longitude and latitude', rl_plon, rl_plat
+	  WRITE(nulou,*) 'Using the nearest non-masked neighbour.' 
+	  WRITE(nulou,*) ' '   
+          
+          ! Search the nearest point in bin [il_min:il_max]
+	  IF (bin==0 .or. bin==1) THEN
+	      il_min=1
+	      il_max=bin_addr1_r(2,3)
+	  ELSE IF (bin==num_srch_red .or. bin==num_srch_red-1) THEN
+	      il_min=bin_addr1_r(1,num_srch_red-2)
+	      il_max=bin_addr1_r(2,num_srch_red)
+	  ELSE
+	      il_min=bin_addr1_r(1,bin-1)+1
+	      il_max=bin_addr1_r(2,bin+2)
+	  END IF
+	 
+	  rl_coslat_dst = COS(rl_plat)
+	  rl_sinlat_dst = SIN(rl_plat)
+	  rl_coslon_dst = COS(rl_plon)
+	  rl_sinlon_dst = SIN(rl_plon)
+	  
+	  rla_weight(1,1) = bignum
+	  ila_src_add(1,1) = 0
+	  
+	  DO ib_i=il_min, il_max		 	   
+	    IF (grid1_mask(ib_i) .or. ld_extrapdone) THEN
+		rl_distance = &
+		   ACOS(rl_coslat_dst*COS(grid1_center_lat(ib_i))* &
+		   (rl_coslon_dst*COS(grid1_center_lon(ib_i)) + &
+		   rl_sinlon_dst*SIN(grid1_center_lon(ib_i)))+&
+		   rl_sinlat_dst*SIN(grid1_center_lat(ib_i)))
+		IF (rl_distance < rla_weight(1,1)) THEN
+		    rla_weight(1,1) = rl_distance
+		    ila_src_add(1,1) = ib_i
+		END IF
+	    END IF
+	  END DO
+	  rla_weight(:,:) = 0
+	  rla_weight(1,1) = 1
+	  
+	  CALL store_link_bicub(ib_dst_add, ila_src_add, rla_weight)
+	  WRITE(nulou,*)  &
+	     'Nearest non masked neighbour is source point ', &
+	     ila_src_add(1,1)
+	  WRITE(nulou,*) 'with longitude and latitude', &
+	     grid1_center_lon(ila_src_add(1,1)), &
+	     grid1_center_lat(ila_src_add(1,1)) 
+	  WRITE(nulou,*) '  '
+	  PRINT*,'Bip bip'
+	  
+	  CYCLE 
+      END IF
+
+      rla_weight(:,:) = 0
+      ! if there is only one point found, save it
+      IF (SUM(ila_nbr_found)==1) THEN   
+	  DO ib_i=1,4
+	    IF (ila_nbr_found(ib_i)==1) THEN
+		rla_weight(ib_i,1)=1
+		EXIT
+	    END IF
+	  END DO
+	  CALL store_link_bicub(ib_dst_add, ila_src_add, rla_weight)
+	  CYCLE
+      END IF
+
+      ! if there are only 2 points found, distance weighted average 
+      IF (SUM(ila_nbr_found)==2) THEN
+	  rl_coslat_dst = COS(rl_plat)
+	  rl_sinlat_dst = SIN(rl_plat)
+	  rl_coslon_dst = COS(rl_plon)
+	  rl_sinlon_dst = SIN(rl_plon)
+	  		    
+	  rl_distance=0  ! count of total distance 
+	  DO ib_i=1,4
+	    IF (ila_nbr_found(ib_i) > 0) THEN
+		rla_weight(ib_i,1) = &
+		   ACOS(rl_coslat_dst*COS(rla_src_lats(ib_i))* &
+		   (rl_coslon_dst*COS(rla_src_lons(ib_i,1)) + &
+		   rl_sinlon_dst*SIN(rla_src_lons(ib_i,1)))+&
+		   rl_sinlat_dst*SIN(rla_src_lats(ib_i)))
+		rl_distance = rl_distance+rla_weight(ib_i,1)
+		IF (ila_nbr_found(ib_i)==2) THEN
+		    rla_weight(ib_i,2) = &
+		       ACOS(rl_coslat_dst*COS(rla_src_lats(ib_i))* &
+		       (rl_coslon_dst*COS(rla_src_lons(ib_i,2)) + &
+		       rl_sinlon_dst*SIN(rla_src_lons(ib_i,2)))+&
+		       rl_sinlat_dst*SIN(rla_src_lats(ib_i)))
+		    rl_distance = rl_distance+rla_weight(ib_i,2)
+		END IF
+	    END IF
+	  END DO
+	  rla_weight=rla_weight/rl_distance
+
+	  CALL store_link_bicub(ib_dst_add, ila_src_add, rla_weight)
+	  CYCLE
+      END IF
+      
+      ! Some case exceptional when just one point per line found 
+      
+      IF (ila_nbr_found(1)==1) THEN  ! elimination of point
+	  ila_nbr_found(1)=0
+	  ila_src_add(1,1)=0
+      END IF
+      IF (ila_nbr_found(4)==1) THEN 
+	  ila_nbr_found(4)=0
+	  ila_src_add(4,1)=0
+      END IF
+      
+     
+
+      IF (ila_nbr_found(2)==1 .or. ila_nbr_found(3)==1) THEN
+	  ila_add_dist(:)=4
+	  rla_dist(:)=bignum
+
+	  ! search for the 2 nearest points or line of points
+	  DO ib_i=1,4
+	    IF (ila_nbr_found(ib_i) > 1) THEN
+		rl_distance=ABS(rla_src_lats(ib_i)-rl_plat)		
+	    ELSE IF (ila_nbr_found(ib_i)==1) THEN
+		rl_coslat_dst = COS(rl_plat)
+		rl_sinlat_dst = SIN(rl_plat)
+		rl_coslon_dst = COS(rl_plon)
+		rl_sinlon_dst = SIN(rl_plon)
+		rl_distance= &	  
+		   ACOS(rl_coslat_dst*COS(rla_src_lats(ib_i))* &
+		   (rl_coslon_dst*COS(rla_src_lons(ib_i,1)) + &
+		   rl_sinlon_dst*SIN(rla_src_lons(ib_i,1)))+&
+		   rl_sinlat_dst*SIN(rla_src_lats(ib_i)))
+	    ELSE
+		rl_distance=bignum
+	    END IF
+
+	    IF (rl_distance < rla_dist(1)) THEN
+		ila_add_dist(2)=ila_add_dist(1)
+		ila_add_dist(1)=ib_i
+		rla_dist(2)=rla_dist(1)
+		rla_dist(1)=rl_distance
+	    ELSE IF (rl_distance < rla_dist(2)) THEN
+		ila_add_dist(2)=ib_i
+		rla_dist(2)=rl_distance
+	    END IF
+	  END DO
+
+	  IF (ila_nbr_found(ila_add_dist(1))>1 .and. &
+	     ila_nbr_found(ila_add_dist(2))>1) THEN
+	      ! linearie
+	      ll_linear=.true.	     
+	  ELSE 
+              ! do distance weighted averege
+	      rla_wght_lon(:,:)=0
+	      DO ib_i=1,2
+		SELECT CASE (ila_nbr_found(ila_add_dist(ib_i)))
+		CASE (4)
+		    CALL calcul_wght_irreg(rla_src_lons(ila_add_dist(ib_i),:),&
+		       rl_plon, rla_wght_lon(ila_add_dist(ib_i),:))	
+		    rla_wght_lon(ila_add_dist(ib_i),:)=&
+		       rla_wght_lon(ila_add_dist(ib_i),:)/& 
+		       rla_dist(ib_i)
+		CASE (3)
+		    CALL calcul_wght_3(rla_src_lons(ila_add_dist(ib_i),1:3),&
+		       rl_plon, rla_wght_lon(ila_add_dist(ib_i),1:3))
+		    rla_wght_lon(ila_add_dist(ib_i),1:3)=&
+		       rla_wght_lon(ila_add_dist(ib_i),1:3)/& 
+		       rla_dist(ib_i)
+		CASE (2)	    
+		    CALL calcul_wght_2(rla_src_lons(ila_add_dist(ib_i),1:2),&
+		       rl_plon, rla_wght_lon(ila_add_dist(ib_i),1:2))
+		    rla_wght_lon(ila_add_dist(ib_i),1:2)=&
+		       rla_wght_lon(ila_add_dist(ib_i),1:2)/& 
+		       rla_dist(ib_i)
+		CASE (1)
+		    rla_wght_lon(ila_add_dist(ib_i),1)=1/rla_dist(ib_i)
+		END SELECT
+	      END DO
+	      rl_distance=0
+	      DO ib_i=1,4
+		rl_distance=rl_distance + sum(rla_wght_lon(ib_i,:))
+	      END DO
+	      rla_weight(:,:)=rla_wght_lon(:,:)/rl_distance
+
+	      CALL store_link_bicub(ib_dst_add, ila_src_add , rla_weight)
+	      CYCLE
+	  END IF
+      END IF
+
+      !
+      ! Calculation of weights for longitudes
+      !  
+     
+      rla_wght_lon(:,:)=0       
+      DO ib_i=1,4                         
+	SELECT CASE (ila_nbr_found(ib_i))
+	CASE (4)	      
+	    CALL calcul_wght_irreg(rla_src_lons(ib_i,:), rl_plon, &
+	       rla_wght_lon(ib_i,:))
+	CASE (3)
+	    CALL calcul_wght_3(rla_src_lons(ib_i,1:3), rl_plon, &
+	       rla_wght_lon(ib_i,1:3))
+	CASE (2)	    
+	    CALL calcul_wght_2(rla_src_lons(ib_i,1:2), rl_plon, &
+	       rla_wght_lon(ib_i,1:2))	
+	END SELECT	
+      END DO
+
+
+      IF (ll_linear) THEN
+	  rla_wght_lat(:)=0	 
+	  CALL calcul_wght_2(rla_src_lats(ila_add_dist(:)), rl_plat, &
+	     rla_wght_temp(1:2))
+	  rla_wght_lat(ila_add_dist(1))=rla_wght_temp(1)
+	  rla_wght_lat(ila_add_dist(2))=rla_wght_temp(2)
+	  DO ib_i=1,4
+	    rla_weight(ib_i,:)=rla_wght_lat(ib_i)*rla_wght_lon(ib_i,:)
+	  END DO
+	  
+	  CALL store_link_bicub(ib_dst_add, ila_src_add , rla_weight)
+	  CYCLE
+      END IF
+    
+
+      !
+      ! Calculation of weights for latitudes
+      !
+	
+      il_count=0
+      DO ib_i=1,4
+	IF (ila_nbr_found(ib_i)/=0) THEN
+	    il_count=il_count+1
+	    rla_lats_temp(il_count)=rla_src_lats(ib_i)
+	END IF
+      END DO
+      
+      SELECT CASE (il_count)
+      CASE (4)   	   
+	  CALL calcul_wght_irreg(rla_lats_temp, rl_plat, rla_wght_temp(:))
+      CASE (3)
+	  CALL calcul_wght_3(rla_lats_temp(1:3), rl_plat, rla_wght_temp(1:3))
+      CASE (2)
+	  CALL calcul_wght_2(rla_lats_temp(1:2), rl_plat, rla_wght_temp(1:2))
+      CASE (1)
+	  rla_wght_temp(1)=1
+      END SELECT
+      
+      il_count=0
+      DO ib_i=1,4
+	IF (ila_nbr_found(ib_i)/=0) THEN
+	    il_count=il_count+1
+	    rla_wght_lat(ib_i)=rla_wght_temp(il_count)
+	ELSE
+	    rla_wght_lat(ib_i)=0
+	END IF
+      END DO
+      
+      ! 
+      ! Calculation of total weight, elementwise multiplication
+      !
+	
+      DO ib_i=1,4
+	rla_weight(ib_i,:)=rla_wght_lat(ib_i)*rla_wght_lon(ib_i,:)
+      END DO     
+      
+      CALL store_link_bicub(ib_dst_add, ila_src_add , rla_weight)
+
+    END DO
+       
+  END SUBROUTINE remap_bicub_reduced
+    
+    
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE: grid_search_16_points
+!
+! !INTERFACE:
+!  
+  SUBROUTINE grid_search_16_points(ida_src_add,   rda_src_lats, rda_src_lons,&
+                                   ida_nbr_found, bin,          rd_plat, &
+				   rd_plon,       ld_extrapdone)
+!    
+! !USES:
+!  
+! !RETURN VALUE:
+!    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4,4), INTENT(out) :: &
+       ida_src_add    ! searched addresses of the unmasked points enclosing
+                      ! target point
+      
+    REAL (KIND=ip_realwp_p), DIMENSION(4,4), INTENT(out) :: &
+       rda_src_lons   ! longitudes of the searched points
+
+    REAL (KIND=ip_realwp_p), DIMENSION(4), INTENT(out) :: &
+       rda_src_lats   ! latitudes  of the searched points 
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4), INTENT(out) :: &
+       ida_nbr_found  ! indicates for each line how many points found
+    
+    INTEGER (KIND=ip_intwp_p), INTENT(out) :: &
+       bin            ! actual bin for target point
+!    
+! !PARAMETERS:
+!  
+    REAL (KIND=ip_realwp_p), INTENT(in) :: &
+       rd_plat, &     ! latitude  of the target point
+       rd_plon      ! longitude of the target point
+          
+    LOGICAL, INTENT(in) :: ld_extrapdone ! true if extrapolation done
+    
+    INTEGER (KIND=ip_intwp_p) :: &
+       ib_k, ib_j, ib_i, &        ! iteration indices
+       il_min, il_max, il_inter   ! begin and end for actual bin
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4,2) :: &
+       ila_corners                ! temp addresses for bins   
+                       
+!
+! !DESCRIPTION:   
+!  This routine finds the location of the target point in the source
+!  grid and returns those of the 16 nearest points that are unmasked.
+!  The source grid is a reduced grid. 
+!
+! !REVISION HISTORY:
+!  2002.10.21  J.Ghattas   created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------   
+      
+     
+    !
+    ! serch of actual bin
+    !
+     
+    
+    IF (rd_plat > bin_lats_r(1,1)) THEN ! norther of the first bin
+	bin=0
+	ila_corners(1:2,1:2)= 0	  
+	ila_corners(3,1)= bin_addr1_r(1,1)+1
+	ila_corners(3,2)= bin_addr1_r(2,1)
+	ila_corners(4,1)= bin_addr1_r(1,2)
+	ila_corners(4,2)= bin_addr1_r(2,2)
+	
+    ELSE IF (rd_plat > bin_lats_r(1,2)) THEN ! in the first bin
+	bin=1
+	ila_corners(1,1:2)= 0
+	ila_corners(2,1)= bin_addr1_r(1,1)+1
+	ila_corners(2,2)= bin_addr1_r(2,1)
+	ila_corners(3,1)= bin_addr1_r(1,2)
+	ila_corners(3,2)= bin_addr1_r(2,2)
+	ila_corners(4,1)= bin_addr1_r(1,3)  
+	ila_corners(4,2)= bin_addr1_r(2,3)
+		
+    ELSE IF (rd_plat < bin_lats_r(1,num_srch_red)) THEN 
+        ! South of the last complet bin
+	bin=num_srch_red
+	ila_corners(1,1) = bin_lats_r(1,num_srch_red-1)
+	ila_corners(1,2) = bin_lats_r(2,num_srch_red-1)
+	ila_corners(2,1) = bin_lats_r(1,num_srch_red)
+	ila_corners(2,2) = bin_lats_r(2,num_srch_red)
+	ila_corners(3:4,1:2) = 0                               
+	  	  
+    ELSE IF (rd_plat < bin_lats_r(1,num_srch_red-1)) THEN
+        ! in the last bin which is complet
+        ! the bin (num_srch_red-1) is the last bin which is complet
+	bin=num_srch_red-1
+	ila_corners(1,1) = bin_lats_r(1,num_srch_red-2)
+	ila_corners(1,2) = bin_lats_r(2,num_srch_red-2)
+	ila_corners(2,1) = bin_lats_r(1,num_srch_red-1)
+	ila_corners(2,2) = bin_lats_r(2,num_srch_red-1)
+	ila_corners(3,1) = bin_lats_r(1,num_srch_red)
+	ila_corners(3,2) = bin_lats_r(2,num_srch_red)
+	ila_corners(4,1:2) = 0 	  
+	
+    ELSE  
+	il_min=2
+	il_max=num_srch_red
+	DO WHILE (il_min /= il_max-1)
+	  il_inter=(il_max-il_min)/2 + il_min
+	  IF (rd_plat <= bin_lats_r(1,il_min) .and. &
+	     rd_plat > bin_lats_r(1,il_inter)) THEN
+	      il_max=il_inter
+	  ELSE
+	      il_min=il_inter
+	  END IF
+	END DO
+	bin=il_min
+	ila_corners(1,1) = bin_addr1_r(1,bin-1)
+	ila_corners(1,2) = bin_addr1_r(2,bin-1)
+	ila_corners(2,1) = bin_addr1_r(1,bin)
+	ila_corners(2,2) = bin_addr1_r(2,bin)
+	ila_corners(3,1) = bin_addr1_r(1,bin+1) 
+	ila_corners(3,2) = bin_addr1_r(2,bin+1)
+	ila_corners(4,1) = bin_addr1_r(1,bin+2) 
+	ila_corners(4,2) = bin_addr1_r(2,bin+2) 
+	
+	IF (ila_corners(1,1)==0) THEN 
+	    ila_corners(1,1)=1
+	END IF	
+    END IF
+      
+    rda_src_lats(:)= grid1_center_lat(ila_corners(:,1))
+     
+
+    !
+    ! now perform a more detailed search for each line
+    !
+     
+    ida_src_add(:,:)=0
+    ida_nbr_found(:)=0
+    rda_src_lons(:,:)=0
+    
+    DO ib_k=1,4 ! for each line of found points
+      IF (ila_corners(ib_k,1)==0) THEN
+	  CYCLE 
+      END IF
+
+      il_min=ila_corners(ib_k,1)
+      il_max=ila_corners(ib_k,2)
+
+      IF (rd_plon < grid1_center_lon(il_min)) THEN	    	   
+	  DO ib_j=il_max-1, il_max
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)-pi2
+	    END IF
+	  END DO
+	  DO ib_j=il_min, il_min+1
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)
+	    END IF
+	  END DO
+	  
+      ELSE IF (rd_plon < grid1_center_lon(il_min+1)) THEN
+	  IF (grid1_mask(il_max) .or. ld_extrapdone) THEN 
+	      ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+	      ida_src_add(ib_k,ida_nbr_found(ib_k)) = il_max
+	      rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		 grid1_center_lon(il_max)-pi2
+	  END IF
+	  DO ib_j=il_min, il_min+2
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)
+	    END IF
+	  END DO
+	  
+      ELSE IF (rd_plon > grid1_center_lon(il_max)) THEN
+	  DO ib_j=il_max-1, il_max
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)
+	    END IF
+	  END DO
+	  DO ib_j=il_min, il_min+1
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)+pi2
+	    END IF
+	  END DO
+	  
+      ELSE IF (rd_plon > grid1_center_lon(il_max-1)) THEN
+	  DO ib_j=il_max-2, il_max
+	    IF (grid1_mask(ib_j) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k)) = ib_j
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_j)
+	    END IF
+	  END DO
+	  IF (grid1_mask(il_min) .or. ld_extrapdone) THEN 
+	      ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+	      ida_src_add(ib_k,ida_nbr_found(ib_k)) = il_min
+	      rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		 grid1_center_lon(il_min)+pi2
+	  END IF
+	  
+      ELSE 	  
+	  
+	  DO WHILE (il_min/=il_max-1)
+	    il_inter=(il_max-il_min)/2 + il_min
+	    IF (rd_plon >= grid1_center_lon(il_min) .and. &
+	       rd_plon < grid1_center_lon(il_inter)) THEN
+		il_max=il_inter
+	    ELSE
+		il_min=il_inter
+	    END IF
+	  END DO
+	  DO ib_i= il_min-1, il_min+2
+	    IF (grid1_mask(ib_i) .or. ld_extrapdone) THEN 
+		ida_nbr_found(ib_k)=ida_nbr_found(ib_k)+1
+		ida_src_add(ib_k,ida_nbr_found(ib_k))=ib_i
+		rda_src_lons(ib_k,ida_nbr_found(ib_k))= &
+		   grid1_center_lon(ib_i)
+	    END IF
+	  END DO	  	  
+
+      END IF
+	
+    END DO
+
+    
+  END SUBROUTINE grid_search_16_points
+  
+
+
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE:  calcul_wght_irreg
+!
+! !INTERFACE:
+! 
+  SUBROUTINE calcul_wght_irreg(rda_x, rd_pt, rda_wght)
+!  
+! !USES:
+!		       
+! !RETURN VALUE:
+!  
+    REAL (KIND=ip_realwp_p), DIMENSION(4), INTENT(out) :: &
+       rda_wght   ! array of weights for the points x
+!      
+! !PARAMETERS:
+! 
+    REAL (KIND=ip_realwp_p), DIMENSION(4), INTENT(in) :: &
+       rda_x ! array of positions on source grid, lat or lon
+      
+    REAL (KIND=ip_realwp_p),INTENT(in) :: &
+       rd_pt  ! position of target point to interpolate
+       
+    REAL (KIND=ip_realwp_p) :: &
+       rl_t1, rl_t2, rl_t3, rl_t4, rl_t5, rl_t6, rl_t7, rl_t8, rl_t9, &
+       rl_u1, rl_u2, rl_u3, rl_u4, &
+       rl_k1, rl_k2, rl_k3, &
+       rl_d1, rl_d2, rl_d3, rl_d4, &
+       rl_c1, rl_c2, rl_c3, rl_c4, &
+       rl_b1, rl_b2, rl_b3, rl_b4, &
+       rl_a1, rl_a2, rl_a3, rl_a4, &
+       rl_y1, rl_y2, rl_y3, &
+       rl_a1_y, rl_a2_y, rl_a3_y, rl_a4_y, &
+       rl_b1_y, rl_b2_y, rl_b3_y, rl_b4_y, &
+       rl_c1_y, rl_c2_y, rl_c3_y, rl_c4_y
+!		       
+! !DESCRIPTION:
+!  Calculates a the weights of four points for a bicubic interpolation. 
+!  The distances between the points can be irregulier. 
+!
+! !REVISION HISTORY:
+!  2002.10.21  J.Ghattas  created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------    
+ 
+    
+    IF (rda_x(1)/=0.and. rda_x(2)/=0 .and. rda_x(3)/=0 .and. rda_x(4)/=0) THEN
+	  
+	rl_t1 = 1/rda_x(1) - 1/rda_x(2)
+	rl_t2 = 1/rda_x(1)**2 - 1/rda_x(2)**2
+	rl_t3 = 1/rda_x(1)**3 - 1/rda_x(2)**3
+	rl_t4 = 1/rda_x(1) - 1/rda_x(3)
+	rl_t5 = 1/rda_x(1)**2 - 1/rda_x(3)**2
+	rl_t6 = 1/rda_x(1)**3 - 1/rda_x(3)**3
+	rl_t7 = 1/rda_x(1) - 1/rda_x(4)
+	rl_t8 = 1/rda_x(1)**2 - 1/rda_x(4)**2
+	rl_t9 = 1/rda_x(1)**3 - 1/rda_x(4)**3
+	  
+	rl_u1 = rl_t2/rl_t1 - rl_t5/rl_t4
+	rl_u2 = rl_t3/rl_t1 - rl_t6/rl_t4
+	rl_u3 = rl_t2/rl_t1 - rl_t8/rl_t7
+	rl_u4 = rl_t3/rl_t1 - rl_t9/rl_t7
+	
+	rl_k1 = (1/(rl_t1*rl_u1)-1/(rl_t1*rl_u3)) / (rl_u2/rl_u1-rl_u4/rl_u3)
+	rl_k2 = -1/(rl_t4*rl_u1) / (rl_u2/rl_u1-rl_u4/rl_u3)
+	rl_k3 = 1/(rl_t7*rl_u3) / (rl_u2/rl_u1-rl_u4/rl_u3)
+	
+	
+	rl_d1=(rl_k1+rl_k2+rl_k3)/rda_x(1)**3
+	rl_d2 = -rl_k1/rda_x(2)**3
+	rl_d3 = -rl_k2/rda_x(3)**3
+	rl_d4 = -rl_k3/rda_x(4)**3
+	
+	rl_c1 = 1/rl_u1*(1/(rl_t1*rda_x(1)**3)-1/(rl_t4*rda_x(1)**3)- &
+	   rl_u2*rl_d1)
+	rl_c2 = 1/rl_u1*(1/(-rl_t1*rda_x(2)**3)-rl_u2*rl_d2)
+	rl_c3 = 1/rl_u1*(1/(rl_t4*rda_x(3)**3)-rl_u2*rl_d3)
+	rl_c4 = 1/rl_u1*(-rl_u2*rl_d4)
+	
+	rl_b1 = 1/rl_t1/rda_x(1)**3-rl_t2/rl_t1*rl_c1-rl_t3/rl_t1*rl_d1
+	rl_b2 = -1/rl_t1/rda_x(2)**3-rl_t2/rl_t1*rl_c2-rl_t3/rl_t1*rl_d2
+	rl_b3 = -rl_t2/rl_t1*rl_c3-rl_t3/rl_t1*rl_d3
+	rl_b4 = -rl_t2/rl_t1*rl_c4-rl_t3/rl_t1*rl_d4
+	
+	rl_a1 = 1/rda_x(1)**3-1/rda_x(1)*rl_b1-1/rda_x(1)**2*rl_c1- &
+	   1/rda_x(1)**3*rl_d1
+	rl_a2 = -1/rda_x(1)*rl_b2-1/rda_x(1)**2*rl_c2-1/rda_x(1)**3*rl_d2
+	rl_a3 = -1/rda_x(1)*rl_b3-1/rda_x(1)**2*rl_c3-1/rda_x(1)**3*rl_d3
+	rl_a4 = -1/rda_x(1)*rl_b4-1/rda_x(1)**2*rl_c4-1/rda_x(1)**3*rl_d4
+	
+       ! Weights  
+	rda_wght(1) = rl_a1*rd_pt**3 + rl_b1*rd_pt**2 + rl_c1*rd_pt + rl_d1
+	rda_wght(2) = rl_a2*rd_pt**3 + rl_b2*rd_pt**2 + rl_c2*rd_pt + rl_d2
+	rda_wght(3) = rl_a3*rd_pt**3 + rl_b3*rd_pt**2 + rl_c3*rd_pt + rl_d3
+	rda_wght(4) = rl_a4*rd_pt**3 + rl_b4*rd_pt**2 + rl_c4*rd_pt + rl_d4
+	
+    ELSE ! there is one point = 0
+	  
+	rl_d1=0; rl_d2=0; rl_d3=0; rl_d4=0
+	
+        ! Transformation for each case
+	IF (rda_x(1)==0) THEN
+	    rl_y1=rda_x(2); rl_y2=rda_x(3); rl_y3=rda_x(4)
+	    rl_d1=1
+	ELSE IF (rda_x(2)==0) THEN
+	    rl_y1=rda_x(1); rl_y2=rda_x(3); rl_y3=rda_x(4)
+	    rl_d2=1
+	ELSE IF (rda_x(3)==0) THEN
+	    rl_y1=rda_x(1); rl_y2=rda_x(2); rl_y3=rda_x(4)
+	    rl_d3=1
+	ELSE 
+	    rl_y1=rda_x(1); rl_y2=rda_x(2); rl_y3=rda_x(3)
+	    rl_d4=1
+	END IF
+	
+        ! Solving the system 
+	rl_t1 = 1/rl_y1-1/rl_y2
+	rl_t2 = 1/rl_y1**2-1/rl_y2**2
+	rl_t3 = 1/rl_y1-1/rl_y3
+	rl_t4 = 1/rl_y1**2-1/rl_y3**2
+	
+	rl_c1_y =(1/rl_y1**3/rl_t1-1/rl_y1**3/rl_t3)/(rl_t2/rl_t1-rl_t4/rl_t3)
+	rl_c2_y = -1/rl_y2**3/rl_t1/(rl_t2/rl_t1-rl_t4/rl_t3)
+	rl_c3_y = 1/rl_y3**3/rl_t3/(rl_t2/rl_t1-rl_t4/rl_t3)
+	rl_c4_y=(-1/rl_y1**3/rl_t1+1/rl_y2**3/rl_t1+ &
+	   1/rl_y1**3/rl_t3-1/rl_y3**3/rl_t3)/(rl_t2/rl_t1-rl_t4/rl_t3)
+	
+	rl_b1_y = 1/rl_y1**3/rl_t1 - rl_c1_y*rl_t2/rl_t1
+	rl_b2_y = -1/rl_y2**3/rl_t1 - rl_c2_y*rl_t2/rl_t1
+	rl_b3_y = -rl_c3_y*rl_t2/rl_t1
+	rl_b4_y = -1/rl_y1**3/rl_t1 + 1/rl_y2**3/rl_t1 - rl_c4_y*rl_t2/rl_t1
+	
+	rl_a1_y = 1/rl_y1**3 - rl_b1_y/rl_y1 - rl_c1_y/rl_y1**2
+	rl_a2_y = -rl_b2_y/rl_y1 - rl_c2_y/rl_y1**2
+	rl_a3_y = -rl_b3_y/rl_y1 - rl_c3_y/rl_y1**2
+	rl_a4_y = -1/rl_y1**3 - rl_b4_y/rl_y1 - rl_c4_y/rl_y1**2
+	  
+        ! Retransformation
+	IF (rda_x(1)==0) THEN
+	    rl_a1=rl_a4_y; rl_a2=rl_a1_y; rl_a3=rl_a2_y; rl_a4=rl_a3_y
+	    rl_b1=rl_b4_y; rl_b2=rl_b1_y; rl_b3=rl_b2_y; rl_b4=rl_b3_y
+	    rl_c1=rl_c4_y; rl_c2=rl_c1_y; rl_c3=rl_c2_y; rl_c4=rl_c3_y
+	ELSE IF (rda_x(2)==0) THEN
+	    rl_a1=rl_a1_y; rl_a2=rl_a4_y; rl_a3=rl_a2_y; rl_a4=rl_a3_y
+	    rl_b1=rl_b1_y; rl_b2=rl_b4_y; rl_b3=rl_b2_y; rl_b4=rl_b3_y
+	    rl_c1=rl_c1_y; rl_c2=rl_c4_y; rl_c3=rl_c2_y; rl_c4=rl_c3_y
+	ELSE IF (rda_x(3)==0) THEN
+	    rl_a1=rl_a1_y; rl_a2=rl_a2_y; rl_a3=rl_a4_y; rl_a4=rl_a3_y
+	    rl_b1=rl_b1_y; rl_b2=rl_b2_y; rl_b3=rl_b4_y; rl_b4=rl_b3_y
+	    rl_c1=rl_c1_y; rl_c2=rl_c2_y; rl_c3=rl_c4_y; rl_c4=rl_c3_y
+	ELSE 
+	    rl_a1=rl_a1_y; rl_a2=rl_a2_y; rl_a3=rl_a3_y; rl_a4=rl_a4_y
+	    rl_b1=rl_b1_y; rl_b2=rl_b2_y; rl_b3=rl_b3_y; rl_b4=rl_b4_y
+	    rl_c1=rl_c1_y; rl_c2=rl_c2_y; rl_c3=rl_c3_y; rl_c4=rl_c4_y
+	END IF
+	
+        ! Weights  
+	rda_wght(1) = rl_a1*rd_pt**3 + rl_b1*rd_pt**2 + rl_c1*rd_pt +rl_d1
+	rda_wght(2) = rl_a2*rd_pt**3 + rl_b2*rd_pt**2 + rl_c2*rd_pt +rl_d2
+	rda_wght(3) = rl_a3*rd_pt**3 + rl_b3*rd_pt**2 + rl_c3*rd_pt +rl_d3
+	rda_wght(4) = rl_a4*rd_pt**3 + rl_b4*rd_pt**2 + rl_c4*rd_pt +rl_d4
+	
+    END IF
+      
+      
+  END SUBROUTINE calcul_wght_irreg
+  
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE:  calcul_wght_3
+!
+! !INTERFACE:
+  
+  SUBROUTINE calcul_wght_3(rda_x, rd_pt, rda_wght)
+
+! !USES:
+  
+! !RETURN VALUE:
+ 
+    REAL (KIND=ip_realwp_p), DIMENSION(3), INTENT(out) :: &
+       rda_wght         ! array of weights for the points x
+    
+! !PARAMETERS:
+
+    REAL (KIND=ip_realwp_p), DIMENSION(3), INTENT(in) :: &
+       rda_x         ! array of positions on source grid, lat or lon
+    
+    REAL (KIND=ip_realwp_p), INTENT(in) :: &
+       rd_pt        ! position of target point to interpolate
+    
+    REAL (KIND=ip_realwp_p) :: &
+       rl_c1, rl_c2, rl_c3, &
+       rl_a1, rl_a2, rl_a3, &
+       rl_b1, rl_b2, rl_b3, &
+       rl_t1, rl_t2, rl_t3, rl_t4
+      
+! !DESCRIPTION:
+!  Calculates a the weights of 3 points for a parabolic interpolation.
+! 
+! !REVISION HISTORY:
+!  2002.10.21  J.Ghattas  created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------
+    
+    
+    IF (rda_x(1)/=0 .and. rda_x(2)/=0 .and. rda_x(3)/=0) THEN    
+	rl_t1 = 1/rda_x(1)-1/rda_x(2)
+	rl_t2 = 1/rda_x(1)**2-1/rda_x(2)**2
+	rl_t3 = 1/rda_x(1)-1/rda_x(3)
+	rl_t4 = 1/rda_x(1)**2-1/rda_x(3)**2
+	
+	rl_c1 = (1/rda_x(1)**2/rl_t1-1/rda_x(1)**2/rl_t3) / &
+	   (rl_t2/rl_t1-rl_t4/rl_t3)
+	rl_c2 = -1/rda_x(2)**2/rl_t1 / (rl_t2/rl_t1-rl_t4/rl_t3)
+	rl_c3 = 1/rda_x(3)**2/rl_t3 / (rl_t2/rl_t1-rl_t4/rl_t3)
+	
+	rl_b1 = 1/rda_x(1)**2/rl_t1 - rl_c1*rl_t2/rl_t1
+	rl_b2 = -1/rda_x(2)**2/rl_t1 - rl_c2*rl_t2/rl_t1
+	rl_b3 = - rl_c3*rl_t2/rl_t1
+	
+	rl_a1 = 1/rda_x(1)**2 - rl_b1/rda_x(1) - rl_c1/rda_x(1)**2
+	rl_a2 = - rl_b2/rda_x(1) - rl_c2/rda_x(1)**2
+	rl_a3 = - rl_b3/rda_x(1) - rl_c3/rda_x(1)**2
+	
+	
+    ELSE IF (rda_x(1)==0) THEN
+	rl_c1 = 1; rl_c2 = 0; rl_c3 = 0
+	rl_b1 = (-1/rda_x(2)**2+1/rda_x(3)**2) / (1/rda_x(2)-1/rda_x(3))
+	rl_b2 = 1/rda_x(2)**2 / (1/rda_x(2)-1/rda_x(3))
+	rl_b3 = -1/rda_x(3)**2 / (1/rda_x(2)-1/rda_x(3))
+	
+	rl_a1 = -1/rda_x(2)**2 - rl_b1/rda_x(2)
+	rl_a2 = 1/rda_x(2)**2 - rl_b2/rda_x(2)
+	rl_a3 = - rl_b3/rda_x(2)
+	
+    ELSE IF (rda_x(2)==0) THEN
+	
+	rl_c1 = 0; rl_c2 = 1; rl_c3 = 0
+	rl_b1 = 1/rda_x(1)**2 / (1/rda_x(1)-1/rda_x(3))
+	rl_b2 = (-1/rda_x(1)**2+1/rda_x(3)**2) / (1/rda_x(1)-1/rda_x(3))
+	rl_b3 = -1/rda_x(3)**2 / (1/rda_x(1)-1/rda_x(3))
+	
+	rl_a1 = 1/rda_x(1)**2 - rl_b1/rda_x(1)
+	rl_a2 = -1/rda_x(1)**2 - rl_b2/rda_x(1)
+	rl_a3 = - rl_b3/rda_x(1)
+	
+    ELSE !rda_x(3)==0
+	rl_c1 = 0; rl_c2 = 0; rl_c3 = 1
+	rl_b1 = 1/rda_x(1)**2 / (1/rda_x(1)-1/rda_x(2))
+	rl_b2 = -1/rda_x(2)**2 / (1/rda_x(1)-1/rda_x(2))
+	rl_b3 = (-1/rda_x(1)**2+1/rda_x(2)**2) / (1/rda_x(1)-1/rda_x(2))
+	
+	rl_a1 = 1/rda_x(1)**2 - rl_b1/rda_x(1)
+	rl_a2 = - rl_b2/rda_x(1)
+	rl_a3 = -1/rda_x(1)**2 - rl_b3/rda_x(1)
+	
+	
+    END IF
+   
+    ! Weights  
+    rda_wght(1) = rl_a1*rd_pt**2 + rl_b1*rd_pt + rl_c1
+    rda_wght(2) = rl_a2*rd_pt**2 + rl_b2*rd_pt + rl_c2
+    rda_wght(3) = rl_a3*rd_pt**2 + rl_b3*rd_pt + rl_c3
+    
+    
+  END SUBROUTINE calcul_wght_3
+    
+
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE:  calcul_wght_2
+!
+! !INTERFACE:
+
+  SUBROUTINE calcul_wght_2(rda_x, rd_pt, rda_wght)
+ 		       
+! !USES:
+		       
+! !RETURN VALUE:
+  
+    REAL (KIND=ip_realwp_p), DIMENSION(2), INTENT(out) :: &
+       rda_wght      ! array of weights for the points x
+     
+! !PARAMETERS:
+
+    REAL (KIND=ip_realwp_p), DIMENSION(2), INTENT(in) :: &
+       rda_x      ! array of positions on source grid, lat or lon
+      
+    REAL (KIND=ip_realwp_p), INTENT(in) :: &
+       rd_pt     ! position of target point to interpolate
+    
+    REAL (KIND=ip_realwp_p) :: rl_b1, rl_b2, rl_a1, rl_a2
+    		       
+! !DESCRIPTION:
+!  Calculates a the weights of 2 points for a linair interpolation.
+!
+! !REVISION HISTORY:
+!  2002.10.21   J.Ghattas    created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------  
+    
+     
+    IF (rda_x(1)/=0 .and. rda_x(2)/=0) THEN
+	rl_b1 = 1/(1-rda_x(1)/rda_x(2))
+	rl_b2 = -1/(rda_x(2)/rda_x(1)-1)
+	rl_a1 = 1/rda_x(1) - rl_b1/rda_x(1)
+	rl_a2 = - rl_b2/rda_x(1)
+	
+    ELSE IF (rda_x(1)==0) THEN
+	rl_b1=1; rl_b2=0
+	rl_a1=-1/rda_x(2)
+	rl_a2=1/rda_x(2)
+    ELSE
+	rl_b1=0; rl_b2=1
+	rl_a1=1/rda_x(1)
+	rl_a2=-1/rda_x(1)
+    END IF
+      
+    rda_wght(1) = rl_a1*rd_pt + rl_b1 
+    rda_wght(2) = rl_a2*rd_pt + rl_b2
+    
+  END SUBROUTINE calcul_wght_2
+    
+
+!-----------------------------------------------------------------------
+! BOP
+!
+! !IROUTINE:  store_link_bicub
+!
+! !INTERFACE:
+ 
+  SUBROUTINE store_link_bicub(id_dst_add, ida_src_add, rda_wght)
+    
+! !USES:
+  
+! !RETURN VALUE:
+
+! !PARAMETERS:
+
+    INTEGER (KIND=ip_intwp_p), INTENT(in) :: &
+       id_dst_add    ! address on destination grid
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(4,4), INTENT(in) :: &
+       ida_src_add   ! addresses for links on source grid
+    
+    REAL (KIND=ip_realwp_p), DIMENSION(4,4), INTENT(in) :: &
+       rda_wght      ! array of remapping weights for these links
+      
+    INTEGER (KIND=ip_intwp_p) :: ib_i, &
+       il_num_links_old  ! placeholder for old link number
+    
+    INTEGER (KIND=ip_intwp_p), DIMENSION(16) :: &
+       ila_src_add   ! reshaped addresses
+    
+    REAL (KIND=ip_realwp_p), DIMENSION(16) :: &
+       rla_wght      ! reshaped weights
+    
+! !DESCRIPTION:
+!  This routine stores the addresses and weights for 16 links associated 
+!  with one destination point in the appropriate address.  
+!
+! !REVISION HISTORY:
+!  2002.10.21    J.Ghattas   created
+!
+! EOP
+!-----------------------------------------------------------------------
+! $Id: remap_bicubic_reduced.F90,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+! $Author: adm $
+!-----------------------------------------------------------------------    
+    
+   
+    !
+    ! Increment number of links and check if remap arrays need
+    ! to be increased to accomodate the new link.  then store the link.
+    !
+     
+    il_num_links_old  = num_links_map1
+    num_links_map1 = il_num_links_old + 16
+    
+    IF (num_links_map1 > max_links_map1) THEN
+	CALL resize_remap_vars(1,MAX(resize_increment,16))
+    END IF
+    
+    ila_src_add=RESHAPE(ida_src_add,(/16/))
+    rla_wght=RESHAPE(rda_wght,(/16/))
+    
+    DO ib_i=1,16
+      grid1_add_map1(il_num_links_old+ib_i) = ila_src_add(ib_i)
+      grid2_add_map1(il_num_links_old+ib_i) = id_dst_add
+      wts_map1(1,il_num_links_old+ib_i) = rla_wght(ib_i)
+    END DO
+        
+  END SUBROUTINE store_link_bicub
+    
+    
+END MODULE remap_bicubic_reduced
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear.f	(revision 1677)
@@ -0,0 +1,721 @@
+C****
+C               *****************************
+C               * OASIS MODULE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** remap_bilinear - calculate bilinear remapping
+C
+C     Purpose:
+C     -------
+C     Adaptation of SCRIP 1.4 remap_bilinear module to calculate 
+C     bilinear remapping.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *remap_bilin**
+C
+C     Input:
+C     -----
+C
+C     Output:
+C     ------
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       S. Valcke      2002/09     Treatment for masked point
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for performing an 
+!     bilinear interpolation.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_bilinear.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 remap_bilinear
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid info
+      use remap_vars    ! module containing remap info
+      USE mod_unit
+      USE mod_printing
+      implicit NONE
+
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), parameter ::
+     &    max_iter = 100   ! max iteration count for i,j iteration
+
+      real (kind=dbl_kind), parameter ::
+     &     converge = 1.e-10_dbl_kind  ! convergence criterion
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_bilin (lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the weights for a bilinear interpolation.
+!
+!-----------------------------------------------------------------------
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n,icount, i,
+     &     dst_add,        ! destination address
+     &     iter,           ! iteration counter
+     &     nmap            ! index of current map being computed
+
+      integer (kind=int_kind), dimension(4) :: 
+     &     src_add         ! address for the four source points
+
+      real (kind=dbl_kind), dimension(4)  ::
+     &     src_lats,       ! latitudes  of four bilinear corners
+     &     src_lons,       ! longitudes of four bilinear corners
+     &     wgts            ! bilinear weights for four corners
+
+      real (kind=dbl_kind) ::
+     &     plat, plon,       ! lat/lon coords of destination point
+     &     iguess, jguess,   ! current guess for bilinear coordinate
+     &     deli, delj,       ! corrections to i,j
+     &     dth1, dth2, dth3, ! some latitude  differences
+     &     dph1, dph2, dph3, ! some longitude differences
+     &     dthp, dphp,       ! difference between point and sw corner
+     &     mat1, mat2, mat3, mat4, ! matrix elements
+     &     determinant,      ! matrix determinant
+     &     sum_wgts          ! sum of weights for normalization
+
+      real (kind=dbl_kind) ::  
+     &      coslat_dst, sinlat_dst, coslon_dst, sinlon_dst,
+     &      dist_min, distance, ! for computing dist-weighted avg
+     &      src_latsnn
+
+      integer (kind=int_kind) :: min_add, max_add, srch_add, src_addnn
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid1 to grid2
+!
+!-----------------------------------------------------------------------
+
+      nmap = 1
+      if (grid1_rank /= 2) then
+        stop 'Can not do bilinear interpolation when grid_rank /= 2'
+      endif
+
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop1: do dst_add = 1, grid2_size
+
+        if (.not. grid2_mask(dst_add)) cycle grid_loop1
+
+        plat = grid2_center_lat(dst_add)
+        plon = grid2_center_lon(dst_add)
+
+        !***
+        !*** find nearest square of grid points on source grid
+        !***
+
+        call grid_search_bilin(src_add, src_lats, src_lons,
+     &                         min_add, max_add, 
+     &                         plat, plon, grid1_dims,
+     &                         grid1_center_lat, grid1_center_lon,
+     &                         grid1_bound_box, bin_addr1, lextrapdone)
+
+
+        if (src_add(1) > 0) THEN
+
+          !***
+          !*** if the 4 surrounding points have been found and are 
+          !*** non-masked, do bilinear interpolation
+          !***
+
+          grid2_frac(dst_add) = one
+
+
+          dth1 = src_lats(2) - src_lats(1)
+          dth2 = src_lats(4) - src_lats(1)
+          dth3 = src_lats(3) - src_lats(2) - dth2
+
+          dph1 = src_lons(2) - src_lons(1)
+          dph2 = src_lons(4) - src_lons(1)
+          dph3 = src_lons(3) - src_lons(2)
+
+          if (dph1 >  three*pih) dph1 = dph1 - pi2
+          if (dph2 >  three*pih) dph2 = dph2 - pi2
+          if (dph3 >  three*pih) dph3 = dph3 - pi2
+          if (dph1 < -three*pih) dph1 = dph1 + pi2
+          if (dph2 < -three*pih) dph2 = dph2 + pi2
+          if (dph3 < -three*pih) dph3 = dph3 + pi2
+
+          dph3 = dph3 - dph2
+
+          iguess = half
+          jguess = half
+
+          iter_loop1: do iter=1,max_iter
+
+            dthp = plat - src_lats(1) - dth1*iguess -
+     &                    dth2*jguess - dth3*iguess*jguess
+            dphp = plon - src_lons(1)
+
+            if (dphp >  three*pih) dphp = dphp - pi2
+            if (dphp < -three*pih) dphp = dphp + pi2
+
+            dphp = dphp - dph1*iguess - dph2*jguess - 
+     &                    dph3*iguess*jguess
+
+            mat1 = dth1 + dth3*jguess
+            mat2 = dth2 + dth3*iguess
+            mat3 = dph1 + dph3*jguess
+            mat4 = dph2 + dph3*iguess
+
+            determinant = mat1*mat4 - mat2*mat3
+
+            deli = (dthp*mat4 - mat2*dphp)/determinant
+            delj = (mat1*dphp - dthp*mat3)/determinant
+
+            if (abs(deli) < converge .and. 
+     &          abs(delj) < converge) exit iter_loop1
+
+            iguess = iguess + deli
+            jguess = jguess + delj
+
+          end do iter_loop1
+
+          if (iter <= max_iter) then
+
+            !***
+            !*** successfully found i,j - compute weights
+            !***
+
+            wgts(1) = (one-iguess)*(one-jguess)
+            wgts(2) = iguess*(one-jguess)
+            wgts(3) = iguess*jguess
+            wgts(4) = (one-iguess)*jguess
+
+            call store_link_bilin(dst_add, src_add, wgts, nmap)
+
+          else
+            print *,'Point coords: ',plat,plon
+            print *,'Dest grid lats: ',src_lats
+            print *,'Dest grid lons: ',src_lons
+            print *,'Dest grid addresses: ',src_add
+            print *,'Current i,j : ',iguess, jguess
+            stop 'Iteration for i,j exceed max iteration count'
+          endif
+
+      else if (src_add(1) < 0) THEN
+
+          !***
+          !*** Search for bilinear failed or at least one of the 4
+          !*** neighbours was masked. Do distance-weighted average using
+          !*** the non-masked points among the 4 closest ones. 
+          !***
+
+          IF (nlogprt .eq. 2) then
+              WRITE(nulou,*) ' '
+              WRITE(nulou,*) 
+     &   'WARNING: Cannot make bilinear interpolation for target point'
+     &            ,dst_add
+              WRITE(nulou,*) 
+     &    'Using non-masked points among 4 nearest neighbors.'
+              WRITE(nulou,*) ' '
+          ENDIF
+
+          !***
+          !*** Find the 4 closest points
+          !***
+
+          coslat_dst = cos(plat)
+          sinlat_dst = sin(plat)
+          coslon_dst = cos(plon)
+          sinlon_dst = sin(plon)
+          src_add = 0
+          dist_min = bignum
+          src_lats = bignum
+          do srch_add = min_add,max_add
+            distance=acos(coslat_dst*cos(grid1_center_lat(srch_add))*
+     &          (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &          sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &          sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+            if (distance < dist_min) then
+                sort_loop: do n=1,4
+                if (distance < src_lats(n)) then
+                    do i=4,n+1,-1
+                      src_add (i) = src_add (i-1)
+                      src_lats(i) = src_lats(i-1)
+                    end do
+                    src_add (n) = srch_add
+                    src_lats(n) = distance
+                    dist_min = src_lats(4)
+                    exit sort_loop
+                endif
+                end do sort_loop
+            endif
+          end do
+
+          src_lons = one/(src_lats + tiny)
+          distance = sum(src_lons)
+          src_lats = src_lons/distance
+
+          !***
+          !*** Among 4 closest points, keep only the non-masked ones
+          !***
+
+          icount = 0
+          do n=1,4
+            if (grid1_mask(src_add(n)) .or.
+     &          (.not. grid1_mask(src_add(n)) .and. lextrapdone)) then
+                icount = icount + 1
+            else
+                src_lats(n) = zero
+            endif
+          end do
+
+          if (icount > 0) then
+              !*** renormalize weights
+              sum_wgts = sum(src_lats)
+              wgts(1) = src_lats(1)/sum_wgts
+              wgts(2) = src_lats(2)/sum_wgts
+              wgts(3) = src_lats(3)/sum_wgts
+              wgts(4) = src_lats(4)/sum_wgts
+
+              grid2_frac(dst_add) = one
+              call store_link_bilin(dst_add, src_add, wgts, nmap)
+          ELSE
+              WRITE(nulou,*) '  '
+              WRITE(nulou,*) 
+     &       'All 4 surrounding source grid points are masked'
+              WRITE(nulou,*) 'for target point ',dst_add
+              WRITE(nulou,*) 'with longitude and latitude', plon, plat
+              WRITE(nulou,*) 'Using the nearest non-masked neighbour.' 
+              WRITE(nulou,*) '  '
+
+              src_latsnn = bignum
+              do srch_add = min_add,max_add
+                if (grid1_mask(srch_add) .or.
+     &          (.not. grid1_mask(srch_add) .and. lextrapdone)) then
+                    distance=acos(coslat_dst
+     &                  *cos(grid1_center_lat(srch_add))*
+     &                  (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &                  sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &                  sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+                    if (distance < src_latsnn) then
+                        src_addnn = srch_add
+                        src_latsnn = distance
+                    endif
+                endif
+              end DO
+
+              WRITE(nulou,*) 
+     &        'Nearest non masked neighbour is source point ',src_addnn
+              WRITE(nulou,*) 'with longitude and latitude',
+     &        grid1_center_lon(src_addnn), grid1_center_lat(src_addnn) 
+              WRITE(nulou,*) '  '
+
+              wgts(1) = 1.
+              wgts(2) = 0.
+              wgts(3) = 0.
+              wgts(4) = 0.
+              src_add(1) = src_addnn
+              src_add(2) = 0
+              src_add(3) = 0
+              src_add(4) = 0
+
+              grid2_frac(dst_add) = one
+              call store_link_bilin(dst_add, src_add, wgts, nmap)
+
+          ENDIF
+      ENDIF
+      end do grid_loop1
+
+      end subroutine remap_bilin
+
+!***********************************************************************
+
+      subroutine grid_search_bilin(src_add, src_lats, src_lons, 
+     &                             min_add, max_add,
+     &                             plat, plon, src_grid_dims,
+     &                             src_center_lat, src_center_lon,
+     &                             src_grid_bound_box,
+     &                             src_bin_add, lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the location of the search point plat, plon
+!     in the source grid and returns the corners needed for a bilinear
+!     interpolation.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(4), intent(out) ::
+     &        src_add  ! address of each corner point enclosing P
+
+      real (kind=dbl_kind), dimension(4), intent(out) ::
+     &        src_lats, ! latitudes  of the four corner points
+     &        src_lons  ! longitudes of the four corner points
+
+      integer (kind=int_kind) :: min_add, max_add
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), intent(in) ::
+     &        plat,   ! latitude  of the search point
+     &        plon    ! longitude of the search point
+
+      integer (kind=int_kind), dimension(2), intent(in) ::
+     &        src_grid_dims  ! size of each src grid dimension
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        src_center_lat, ! latitude  of each src grid center 
+     &        src_center_lon  ! longitude of each src grid center
+
+      real (kind=dbl_kind), dimension(:,:), intent(in) ::
+     &        src_grid_bound_box ! bound box for source grid
+
+      integer (kind=int_kind), dimension(:,:), intent(in) ::
+     &        src_bin_add    ! latitude bins for restricting
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, next_n, srch_add, ni,   ! dummy indices
+     &    nx, ny, ntotmask,           ! dimensions of src grid
+     &    i, j, jp1, ip1, n_add, e_add, ne_add  ! addresses
+
+      real (kind=dbl_kind) ::  ! vectors for cross-product check
+     &      vec1_lat, vec1_lon,
+     &      vec2_lat, vec2_lon, cross_product, cross_product_last
+
+!-----------------------------------------------------------------------
+!
+!     restrict search first using bins
+!
+!-----------------------------------------------------------------------
+
+      src_add = 0
+
+      min_add = size(src_center_lat)
+      max_add = 1
+      do n=1,num_srch_bins
+        if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and.
+     &      plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then
+          min_add = min(min_add, src_bin_add(1,n))
+          max_add = max(max_add, src_bin_add(2,n))
+        endif
+      end do
+ 
+!-----------------------------------------------------------------------
+!
+!     now perform a more detailed search 
+!
+!-----------------------------------------------------------------------
+
+      nx = src_grid_dims(1)
+      ny = src_grid_dims(2)
+
+      srch_loop: do srch_add = min_add,max_add
+
+        !*** first check bounding box
+
+        if (plat <= src_grid_bound_box(2,srch_add) .and. 
+     &      plat >= src_grid_bound_box(1,srch_add) .and.
+     &      plon <= src_grid_bound_box(4,srch_add) .and. 
+     &      plon >= src_grid_bound_box(3,srch_add)) then
+
+          !***
+          !*** we are within bounding box so get really serious
+          !***
+
+          !*** determine neighbor addresses
+
+          j = (srch_add - 1)/nx +1
+          i = srch_add - (j-1)*nx
+
+          !*** find ip1
+          !*** Note: I do not want to take into account the number
+          !*** of overlapping grid points, as the underlying cell
+          !*** will be found in all cases if the grid overlaps.
+
+          if (i < nx) then
+            ip1 = i + 1
+          else
+            ip1 = 1
+          endif
+
+          if (j < ny) then
+            jp1 = j+1
+          else
+            jp1 = 1
+          endif
+
+          n_add = (jp1 - 1)*nx + i
+          e_add = (j - 1)*nx + ip1
+          ne_add = (jp1 - 1)*nx + ip1
+
+          src_lats(1) = src_center_lat(srch_add)
+          src_lats(2) = src_center_lat(e_add)
+          src_lats(3) = src_center_lat(ne_add)
+          src_lats(4) = src_center_lat(n_add)
+
+          src_lons(1) = src_center_lon(srch_add)
+          src_lons(2) = src_center_lon(e_add)
+          src_lons(3) = src_center_lon(ne_add)
+          src_lons(4) = src_center_lon(n_add)
+
+          !***
+          !*** for consistency, we must make sure all lons are in
+          !*** same 2pi interval
+          !***
+
+          vec1_lon = src_lons(1) - plon
+          if (vec1_lon >  pi) then
+            src_lons(1) = src_lons(1) - pi2
+          else if (vec1_lon < -pi) then
+            src_lons(1) = src_lons(1) + pi2
+          endif
+          do n=2,4
+            vec1_lon = src_lons(n) - src_lons(1)
+            if (vec1_lon >  pi) then
+              src_lons(n) = src_lons(n) - pi2
+            else if (vec1_lon < -pi) then
+              src_lons(n) = src_lons(n) + pi2
+            endif
+          end do
+
+          corner_loop: do n=1,4
+            next_n = MOD(n,4) + 1
+
+            !***
+            !*** here we take the cross product of the vector making 
+            !*** up each box side with the vector formed by the vertex
+            !*** and search point.  if all the cross products are 
+            !*** positive, the point is contained in the box.
+            !***
+
+            vec1_lat = src_lats(next_n) - src_lats(n)
+            vec1_lon = src_lons(next_n) - src_lons(n)
+            vec2_lat = plat - src_lats(n)
+            vec2_lon = plon - src_lons(n)
+
+            !***
+            !*** check for 0,2pi crossings
+            !***
+
+            if (vec1_lon >  three*pih) then
+              vec1_lon = vec1_lon - pi2
+            else if (vec1_lon < -three*pih) then
+              vec1_lon = vec1_lon + pi2
+            endif
+            if (vec2_lon >  three*pih) then
+              vec2_lon = vec2_lon - pi2
+            else if (vec2_lon < -three*pih) then
+              vec2_lon = vec2_lon + pi2
+            endif
+
+            cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat
+
+            !***
+            !*** if cross product is less than zero, this cell
+            !*** doesn't work
+            !***
+
+            if (n == 1) cross_product_last = cross_product
+            if (cross_product*cross_product_last < zero) 
+     &          exit corner_loop
+            cross_product_last = cross_product
+
+          end do corner_loop
+
+          !***
+          !*** if cross products all same sign, we found the location
+          !***
+
+          if (n > 4) then
+            src_add(1) = srch_add
+            src_add(2) = e_add
+            src_add(3) = ne_add
+            src_add(4) = n_add
+
+           ! Check if one point is masked; IF so, nearest-neighbour
+           ! interpolation will be used  
+
+            ntotmask = 0
+            do ni=1,4
+              if (.not. grid1_mask(src_add(ni)).and. 
+     &            .not. lextrapdone) 
+     &            ntotmask = ntotmask + 1 
+            end DO
+            IF (ntotmask .gt. 0) src_add(1) = -src_add(1)
+        
+            return
+          endif
+
+          !***
+          !*** otherwise move on to next cell
+          !***
+
+        endif !bounding box check
+      end do srch_loop
+
+      !***
+      !*** if no cell found, point is likely either in a box that straddles
+      !*** either pole or is outside the grid. Put src_add = -1 so that
+      !*** distance-weighted average of the 4 non-masked closest points
+      !*** is done in calling routine.
+  
+      src_add = -1
+
+!-----------------------------------------------------------------------
+
+      end subroutine grid_search_bilin 
+
+!***********************************************************************
+
+      subroutine store_link_bilin(dst_add, src_add, weights, nmap)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for four links 
+!     associated with one destination point in the appropriate address 
+!     and weight arrays and resizes those arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        dst_add,  ! address on destination grid
+     &        nmap      ! identifies which direction for mapping
+
+      integer (kind=int_kind), dimension(4), intent(in) ::
+     &        src_add   ! addresses on source grid
+
+      real (kind=dbl_kind), dimension(4), intent(in) ::
+     &        weights ! array of remapping weights for these links
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, ! dummy index
+     &       num_links_old          ! placeholder for old link number
+
+!-----------------------------------------------------------------------
+!
+!     increment number of links and check to see if remap arrays need
+!     to be increased to accomodate the new link.  then store the
+!     link.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        num_links_old  = num_links_map1
+        num_links_map1 = num_links_old + 4
+
+        if (num_links_map1 > max_links_map1) 
+     &     call resize_remap_vars(1,resize_increment)
+
+        do n=1,4
+          grid1_add_map1(num_links_old+n) = src_add(n)
+          grid2_add_map1(num_links_old+n) = dst_add
+          wts_map1    (1,num_links_old+n) = weights(n)
+        end do
+
+      case(2)
+
+        num_links_old  = num_links_map2
+        num_links_map2 = num_links_old + 4
+
+        if (num_links_map2 > max_links_map2) 
+     &     call resize_remap_vars(2,resize_increment)
+
+        do n=1,4
+          grid1_add_map2(num_links_old+n) = dst_add
+          grid2_add_map2(num_links_old+n) = src_add(n)
+          wts_map2    (1,num_links_old+n) = weights(n)
+        end do
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_bilin
+
+!***********************************************************************
+
+      end module remap_bilinear
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear_reduced.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear_reduced.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_bilinear_reduced.f	(revision 1677)
@@ -0,0 +1,650 @@
+C****
+C               *****************************
+C               * OASIS MODULE  -  LEVEL ? *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** remap_bilinear_reduced - calculate reduced grid bilinear remapping
+C
+C     Purpose:
+C     -------
+C     Adaptation of SCRIP 1.4 remap_bilinear module to calculate 
+C     bilinear remapping for reduced grids.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *remap_bilin_reduced*
+C
+C     Input:
+C     -----
+C
+C     Output:
+C     ------
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.5       D. Declat      2002/07     created
+C       2.5       S. Valcke      2002/09     modified
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for performing an 
+!     bilinear interpolation on reduced grids.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_bilinear_reduced.f,v 1.1.1.1 2005/03/23 16:01:11 adm Exp $
+!
+!     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 remap_bilinear_reduced
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid info
+      use remap_vars    ! module containing remap info
+      USE mod_unit
+      USE mod_printing
+
+      implicit none
+
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), parameter ::
+     &    max_iter = 100   ! max iteration count for i,j iteration
+
+      real (kind=dbl_kind), parameter ::
+     &     converge = 1.e-10_dbl_kind  ! convergence criterion
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_bilin_reduced (lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the weights for a bilinear interpolation.
+!
+!-----------------------------------------------------------------------
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, icount, i,
+     &     dst_add,        ! destination address
+     &     iter,           ! iteration counter
+     &     nmap           ! index of current map being computed
+
+      integer (kind=int_kind), dimension(4) :: 
+     &     src_add         ! address for the four source points
+
+      real (kind=dbl_kind), dimension(4)  ::
+     &     src_lats,       ! latitudes  of four bilinear corners
+     &     src_lons,       ! longitudes of four bilinear corners
+     &     wgts            ! bilinear weights for four corners
+
+      real (kind=dbl_kind) ::
+     &     plat, plon,       ! lat/lon coords of destination point
+     &     iguess, jguess,   ! current guess for bilinear coordinate
+     &     deli, delj,       ! corrections to i,j
+     &     dth1, dth2, dth3, ! some latitude  differences
+     &     dph1, dph2, dph3, ! some longitude differences
+     &     dthp, dphp,       ! difference between point and sw corner
+     &     mat1, mat2, mat3, mat4, ! matrix elements
+     &     determinant,       ! matrix determinant
+     &     sum_wgts          ! sum of weights for normalization
+
+      real (kind=dbl_kind) ::  
+     &      coslat_dst, sinlat_dst, coslon_dst, sinlon_dst,
+     &      dist_min, distance, ! for computing dist-weighted avg
+     &      src_latsnn
+
+      integer (kind=int_kind) :: min_add, max_add, srch_add, src_addnn
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid1 to grid2
+!
+!-----------------------------------------------------------------------
+
+      nmap = 1
+      if (grid1_rank /= 2) then
+          stop 'Can not do bilinear interpolation when grid_rank /= 2'
+      endif
+
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop1: do dst_add = 1, grid2_size
+
+         if (.not. grid2_mask(dst_add)) cycle grid_loop1
+
+         plat = grid2_center_lat(dst_add)
+         plon = grid2_center_lon(dst_add)
+
+        !***
+        !*** find nearest square of grid points on source grid
+        !***
+
+        call grid_search_bilin_rd(src_add, src_lats, src_lons, 
+     &                            min_add, max_add,
+     &                            plat, plon, grid1_dims,
+     &                            grid1_center_lat, grid1_center_lon,
+     &                            lextrapdone)
+
+        if (src_add(1) > 0) THEN
+
+        !***
+        !*** if the 4 surrounding points have been found and are 
+        !*** non-masked, do bilinear interpolation
+        !***
+
+          grid2_frac(dst_add) = one
+
+          !***
+          !*** iterate to find i,j for bilinear approximation
+          !***
+
+          dth1 = src_lats(2) - src_lats(1)
+          dth2 = src_lats(4) - src_lats(1)
+          dth3 = src_lats(3) - src_lats(2) - dth2
+
+          dph1 = src_lons(2) - src_lons(1)
+          dph2 = src_lons(4) - src_lons(1)
+          dph3 = src_lons(3) - src_lons(2)
+
+          if (dph1 >  three*pih) dph1 = dph1 - pi2
+          if (dph2 >  three*pih) dph2 = dph2 - pi2
+          if (dph3 >  three*pih) dph3 = dph3 - pi2
+          if (dph1 < -three*pih) dph1 = dph1 + pi2
+          if (dph2 < -three*pih) dph2 = dph2 + pi2
+          if (dph3 < -three*pih) dph3 = dph3 + pi2
+
+          dph3 = dph3 - dph2
+
+          iguess = half
+          jguess = half
+
+          iter_loop1: do iter=1,max_iter
+
+            dthp = plat - src_lats(1) - dth1*iguess -
+     &                    dth2*jguess - dth3*iguess*jguess
+            dphp = plon - src_lons(1)
+
+            if (dphp >  three*pih) dphp = dphp - pi2
+            if (dphp < -three*pih) dphp = dphp + pi2
+
+            dphp = dphp - dph1*iguess - dph2*jguess - 
+     &                    dph3*iguess*jguess
+
+            mat1 = dth1 + dth3*jguess
+            mat2 = dth2 + dth3*iguess
+            mat3 = dph1 + dph3*jguess
+            mat4 = dph2 + dph3*iguess
+
+            determinant = mat1*mat4 - mat2*mat3
+
+            deli = (dthp*mat4 - mat2*dphp)/determinant
+            delj = (mat1*dphp - dthp*mat3)/determinant
+
+            if (abs(deli) < converge .and. 
+     &          abs(delj) < converge) exit iter_loop1
+
+            iguess = iguess + deli
+            jguess = jguess + delj
+
+          end do iter_loop1
+
+          if (iter <= max_iter) then
+
+            !***
+            !*** successfully found i,j - compute weights
+            !***
+
+            wgts(1) = (one-iguess)*(one-jguess)
+            wgts(2) = iguess*(one-jguess)
+            wgts(3) = iguess*jguess
+            wgts(4) = (one-iguess)*jguess
+            call store_link_bilin(dst_add, src_add, wgts, nmap)
+          else
+            print *,'Point coords: ',plat,plon
+            print *,'Dest grid lats: ',src_lats
+            print *,'Dest grid lons: ',src_lons
+            print *,'Dest grid addresses: ',src_add
+            print *,'Current i,j : ',iguess, jguess
+            stop 'Iteration for i,j exceed max iteration count'
+          endif
+
+        else if (src_add(1) < 0) THEN
+
+          !***
+          !*** We are in the first or last bin or at least one of the 4
+          !*** neighbours was masked. Do distance-weighted average using
+          !*** the non-masked points among the 4 closest ones. 
+
+          IF (nlogprt .eq. 2) then
+              WRITE(nulou,*) ' '
+              WRITE(nulou,*) 
+     &   'WARNING: Cannot make bilinear interpolation for target point'
+     &            ,dst_add
+              WRITE(nulou,*) 
+     &    'Using non-masked points among 4 nearest neighbors.'
+              WRITE(nulou,*) ' '
+          ENDIF
+
+          !***
+          !*** Find the 4 closest points
+          !***
+
+          coslat_dst = cos(plat)
+          sinlat_dst = sin(plat)
+          coslon_dst = cos(plon)
+          sinlon_dst = sin(plon)
+          src_add = 0
+          dist_min = bignum
+          src_lats = bignum
+          do srch_add = min_add,max_add
+            distance=acos(coslat_dst*cos(grid1_center_lat(srch_add))*
+     &          (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &          sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &          sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+            if (distance < dist_min) then
+                sort_loop: do n=1,4
+                if (distance < src_lats(n)) then
+                    do i=4,n+1,-1
+                      src_add (i) = src_add (i-1)
+                      src_lats(i) = src_lats(i-1)
+                    end do
+                    src_add (n) = srch_add
+                    src_lats(n) = distance
+                    dist_min = src_lats(4)
+                    exit sort_loop
+                endif
+                end do sort_loop
+            endif
+          end do
+
+          src_lons = one/(src_lats + tiny)
+          distance = sum(src_lons)
+          src_lats = src_lons/distance
+
+          !***
+          !*** Among 4 closest points, keep only the non-masked ones
+          !***
+
+          icount = 0
+          do n=1,4
+            if (grid1_mask(src_add(n)) .or.
+     &          (.not. grid1_mask(src_add(n)) .and. lextrapdone)) then
+                icount = icount + 1
+            else
+                src_lats(n) = zero
+            endif
+          end do
+
+          if (icount > 0) then
+              !*** renormalize weights
+              sum_wgts = sum(src_lats)
+              wgts(1) = src_lats(1)/sum_wgts
+              wgts(2) = src_lats(2)/sum_wgts
+              wgts(3) = src_lats(3)/sum_wgts
+              wgts(4) = src_lats(4)/sum_wgts
+
+              grid2_frac(dst_add) = one
+              call store_link_bilin(dst_add, src_add, wgts, nmap)
+          ELSE
+              WRITE(nulou,*) '  '
+              WRITE(nulou,*) 
+     &       'All 4 surrounding source grid points are masked'
+              WRITE(nulou,*) 'for target point ',dst_add
+              WRITE(nulou,*) 'with longitude and latitude', plon, plat
+              WRITE(nulou,*) 'Using the nearest non-masked neighbour.' 
+              WRITE(nulou,*) '  '
+              src_latsnn = bignum
+              do srch_add = min_add,max_add
+                if (grid1_mask(srch_add) .or.
+     &          (.not. grid1_mask(srch_add) .and. lextrapdone)) then
+                    distance=acos(coslat_dst
+     &                  *cos(grid1_center_lat(srch_add))*
+     &                  (coslon_dst*cos(grid1_center_lon(srch_add)) +
+     &                  sinlon_dst*sin(grid1_center_lon(srch_add)))+
+     &                  sinlat_dst*sin(grid1_center_lat(srch_add)))
+
+                    if (distance < src_latsnn) then
+                        src_addnn = srch_add
+                        src_latsnn = distance
+                    endif
+                endif
+              end DO
+
+              WRITE(nulou,*) 
+     &        'Nearest non masked neighbour is source point ',src_addnn
+              WRITE(nulou,*) 'with longitude and latitude',
+     &        grid1_center_lon(src_addnn), grid1_center_lat(src_addnn) 
+              WRITE(nulou,*) '  '
+
+              wgts(1) = 1.
+              wgts(2) = 0.
+              wgts(3) = 0.
+              wgts(4) = 0.
+              src_add(1) = src_addnn
+              src_add(2) = 0
+              src_add(3) = 0
+              src_add(4) = 0
+
+              grid2_frac(dst_add) = one
+              call store_link_bilin(dst_add, src_add, wgts, nmap)
+
+          ENDIF
+      ENDIF
+      end do grid_loop1
+!
+!-----------------------------------------------------------------------
+
+      end subroutine remap_bilin_reduced
+
+!***********************************************************************
+
+      subroutine grid_search_bilin_rd(src_add, src_lats, src_lons,
+     &                                min_add, max_add,
+     &                                plat, plon, src_grid_dims,
+     &                                src_center_lat, src_center_lon,
+     &                                lextrapdone)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the location of the search point plat, plon
+!     in the source grid and returns the corners needed for a bilinear
+!     interpolation. The target grid is a reduced grid.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(4), intent(out) ::
+     &        src_add  ! address of each corner point enclosing P
+
+      real (kind=dbl_kind), dimension(4), intent(out) ::
+     &        src_lats, ! latitudes  of the four corner points
+     &        src_lons  ! longitudes of the four corner points
+
+      integer (kind=int_kind) :: min_add, max_add
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), intent(in) ::
+     &        plat,   ! latitude  of the search point
+     &        plon    ! longitude of the search point
+
+      integer (kind=int_kind), dimension(2), intent(in) ::
+     &        src_grid_dims  ! size of each src grid dimension
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        src_center_lat, ! latitude  of each src grid center 
+     &        src_center_lon  ! longitude of each src grid center
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, next_n, srch_add, ni,  ! dummy indices
+     &    nx, ny, ntotmask,           ! dimensions of src grid
+     &    inter_add ! add for restricting search
+!
+      integer (kind=int_kind), DIMENSION(4) :: src_bid
+
+!-----------------------------------------------------------------------
+!
+!     restrict search first using bins
+!
+!-----------------------------------------------------------------------
+
+      nx = src_grid_dims(1)
+      inter_add = 0
+
+      src_add = 0
+
+      min_add = size(src_center_lat) + 1
+      max_add = 1
+      if (plat >= bin_lats_r(1,1)) then
+          min_add = 0
+          max_add = bin_addr1_r(4,1)
+          inter_add = bin_addr1_r(3,1)
+      else if (plat <= bin_lats_r(1,num_srch_red)) then
+          max_add = nx + 1
+          min_add = bin_addr1_r(1,num_srch_red)
+          inter_add = bin_addr1_r(3,num_srch_red)
+      else
+          srch_loopred: do n=1,num_srch_red
+            if (plat <= bin_lats_r(1,n) 
+     &        .and. plat >= bin_lats_r(2,n)) then
+                min_add = bin_addr1_r(1,n)
+                max_add = bin_addr1_r(4,n)
+                inter_add = bin_addr1_r(3,n)
+                exit srch_loopred
+            endif
+          end DO srch_loopred
+      ENDIF
+
+!-----------------------------------------------------------------------
+!
+!     now perform a more detailed search 
+!
+!-----------------------------------------------------------------------
+
+      if (min_add .ne. 0 .and. max_add .ne. nx+1) THEN
+         !*** The concerned bins are not the top north or south ones.
+         !*** We should be able to find the four corners
+         !*** for the bilinear interpolation.
+
+          IF ( plon <= src_center_lon(min_add) ) THEN
+              src_add(1) = inter_add-1
+              src_add(2) = min_add
+          ELSE IF ( plon > src_center_lon(inter_add-1) ) then
+              src_add(1) = inter_add-1
+              src_add(2) = min_add
+          else
+              srch_loop2: do srch_add = min_add, inter_add-2
+                 if ( (plon > src_center_lon(srch_add)) .and.
+     &            (plon <= src_center_lon(srch_add+1)) )then
+                     src_add(1) = srch_add
+                     src_add(2) = srch_add+1
+                     exit srch_loop2
+                 endif
+               end do srch_loop2
+           ENDIF
+           IF ( plon <= src_center_lon(inter_add) ) THEN
+               src_add(3) = max_add
+               src_add(4) = inter_add
+           ELSE IF ( plon >= src_center_lon(max_add) ) then
+               src_add(3) = max_add
+               src_add(4) = inter_add
+           else
+               srch_loop3: do srch_add = inter_add, max_add
+                 if ( (plon >= src_center_lon(srch_add)) .and.
+     &             (plon <= src_center_lon(srch_add+1)) )then
+                      src_add(3) = srch_add
+                      src_add(4) = srch_add+1
+                      exit srch_loop3
+                  endif
+               enddo srch_loop3
+           ENDIF
+           src_lats(1) = src_center_lat(src_add(3))
+           src_lats(2) = src_center_lat(src_add(4))
+           src_lats(3) = src_center_lat(src_add(2))
+           src_lats(4) = src_center_lat(src_add(1))
+      
+           src_lons(1) = src_center_lon(src_add(3))
+           src_lons(2) = src_center_lon(src_add(4))
+           src_lons(3) = src_center_lon(src_add(2))
+           src_lons(4) = src_center_lon(src_add(1))
+
+           src_bid=src_add
+
+           src_add(1) = src_bid(3)
+           src_add(2) = src_bid(4)
+           src_add(3) = src_bid(2)
+           src_add(4) = src_bid(1)
+    
+           ! Check if one point is masked; IF so, nearest-neighbour
+           ! interpolation will be used 
+
+           ntotmask = 0
+           do ni=1,4
+             if (.not. grid1_mask(src_add(ni)).and. 
+     &           .not. lextrapdone) 
+     &           ntotmask = ntotmask + 1 
+           end DO
+           IF (ntotmask .gt. 0) src_add(1) = -src_add(1) 
+          
+       ELSE 
+
+           !*** We are in the first or last bin.  Put src_add = -1 so that
+           !*** distance-weighted average of the 4 non-masked closest points
+           !*** is done in calling routine. 
+
+           src_add = -1
+
+       ENDIF
+
+!-----------------------------------------------------------------------
+
+      end subroutine grid_search_bilin_rd 
+
+!***********************************************************************
+
+      subroutine store_link_bilin(dst_add, src_add, weights, nmap)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for four links 
+!     associated with one destination point in the appropriate address 
+!     and weight arrays and resizes those arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        dst_add,  ! address on destination grid
+     &        nmap      ! identifies which direction for mapping
+
+      integer (kind=int_kind), dimension(4), intent(in) ::
+     &        src_add   ! addresses on source grid
+
+      real (kind=dbl_kind), dimension(4), intent(in) ::
+     &        weights ! array of remapping weights for these links
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, ! dummy index
+     &       num_links_old          ! placeholder for old link number
+
+!-----------------------------------------------------------------------
+!
+!     increment number of links and check to see if remap arrays need
+!     to be increased to accomodate the new link.  then store the
+!     link.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        num_links_old  = num_links_map1
+        num_links_map1 = num_links_old + 4
+
+        if (num_links_map1 > max_links_map1) 
+     &     call resize_remap_vars(1,resize_increment)
+
+        do n=1,4
+          grid1_add_map1(num_links_old+n) = src_add(n)
+          grid2_add_map1(num_links_old+n) = dst_add
+          wts_map1    (1,num_links_old+n) = weights(n)
+        end do
+
+      case(2)
+
+        num_links_old  = num_links_map2
+        num_links_map2 = num_links_old + 4
+
+        if (num_links_map2 > max_links_map2) 
+     &     call resize_remap_vars(2,resize_increment)
+
+        do n=1,4
+          grid1_add_map2(num_links_old+n) = dst_add
+          grid2_add_map2(num_links_old+n) = src_add(n)
+          wts_map2    (1,num_links_old+n) = weights(n)
+        end do
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_bilin
+
+!***********************************************************************
+
+      end module remap_bilinear_reduced
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_conserv.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_conserv.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_conserv.f	(revision 1677)
@@ -0,0 +1,2321 @@
+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     Main modifications:
+C       - Some allocated array will be freed in the end to allow multiple
+C         calls of SCRIP
+C       - Introduction of a logical flag to distinguish between the first
+C         and following calls of scrip conservative remapping
+C       - Masking of overlapping grid points for source and target grid
+C         For these points, links and weights of overlapped point are used
+C
+C     Modified by            V. Gayler,  M&D                  20.09.2001
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for computing addresses
+!     and weights for a conservative interpolation  between any two 
+!     grids on a sphere.  the weights are computed by performing line 
+!     integrals around all overlap regions of the two grids.  see 
+!     Dukowicz and Kodis, SIAM J. Sci. Stat. Comput. 8, 305 (1987) and
+!     Jones, P.W. Monthly Weather Review (submitted).
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_conserv.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 remap_conservative
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod    ! defines common data types
+      use constants    ! defines common constants
+      use timers       ! module for timing
+      use grids        ! module containing grid information
+      use remap_vars   ! module containing remap information
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     module variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), DIMENSION(:), allocatable :: 
+     $    grid2_overlap ! overlapping points
+
+      integer (kind=int_kind), save :: 
+     &        num_srch_cells ! num cells in restricted search arrays
+
+      integer (kind=int_kind), dimension(:), allocatable, save :: 
+     &        srch_add       ! global address of cells in srch arrays
+
+      real (kind=dbl_kind), parameter :: 
+     &     north_thresh = 1.45_dbl_kind, ! threshold for coord transf.
+     &     south_thresh =-2.00_dbl_kind  ! threshold for coord transf.
+
+      real (kind=dbl_kind), dimension(:,:), allocatable, save ::
+     &     srch_corner_lat,  ! lat of each corner of srch cells
+     &     srch_corner_lon   ! lon of each corner of srch cells
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_conserv
+
+!-----------------------------------------------------------------------
+!
+!     this routine traces the perimeters of every grid cell on each
+!     grid checking for intersections with the other grid and computing
+!     line integrals for each subsegment.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), parameter :: 
+     &        max_subseg = 10000 ! max number of subsegments per segment
+                                 ! to prevent infinite loop
+
+      integer (kind=int_kind) :: 
+     &        grid1_add,  ! current linear address for grid1 cell
+     &        grid2_add,  ! current linear address for grid2 cell
+     &        min_add,    ! addresses for restricting search of
+     &        max_add,    !   destination grid
+     &        n, nwgt,    ! generic counters
+     &        corner,     ! corner of cell that segment starts from
+     &        next_corn,  ! corner of cell that segment ends on
+     &        num_subseg, ! number of subsegments 
+     &        overunit
+
+      logical (kind=log_kind) :: 
+     &        lcoinc,  ! flag for coincident segments
+     &        lrevers, ! flag for reversing direction of segment
+     &        lbegin,  ! flag for first integration of a segment
+     &        full     !
+
+      logical (kind=log_kind), dimension(:), allocatable ::
+     &        srch_mask   ! mask for restricting searches
+
+      real (kind=dbl_kind) ::
+     &     intrsct_lat, intrsct_lon,       ! lat/lon of next intersect
+     &     beglat, endlat, beglon, endlon, ! endpoints of current seg.
+     &     norm_factor,                    ! factor for normalizing wts
+     &     delta                           ! precision 
+      real (kind=dbl_kind), dimension(:), allocatable ::
+     &       grid2_centroid_lat, grid2_centroid_lon, ! centroid coords
+     &       grid1_centroid_lat, grid1_centroid_lon  ! on each grid
+
+      real (kind=dbl_kind), dimension(2) :: begseg ! begin lat/lon for
+                                                   ! full segment
+
+      real (kind=dbl_kind), dimension(6) :: weights ! local wgt array
+
+!-----------------------------------------------------------------------
+!
+!     initialize centroid arrays
+!
+!-----------------------------------------------------------------------
+
+      allocate( grid1_centroid_lat(grid1_size),
+     &          grid1_centroid_lon(grid1_size),
+     &          grid2_centroid_lat(grid2_size),
+     &          grid2_centroid_lon(grid2_size))
+
+      grid1_centroid_lat = zero
+      grid1_centroid_lon = zero
+      grid2_centroid_lat = zero
+      grid2_centroid_lon = zero
+
+!-----------------------------------------------------------------------
+!
+!     integrate around each cell on grid1
+!
+!-----------------------------------------------------------------------
+
+      allocate(srch_mask(grid2_size))
+
+! Check overlapping point of the source grid
+      
+      PRINT*, 'Check overlapping point of the source grid'
+
+      CALL get_unit(overunit)
+
+      OPEN(overunit, FILE = './overlap.dat', STATUS = 'UNKNOWN')
+      WRITE(overunit, *) 'list of overlapping point of the source grid'
+
+      delta = epsilon(1.)
+
+      do grid1_add = 1,grid1_size
+
+        IF (grid1_mask(grid1_add)) THEN
+            DO n = grid1_add, grid1_size
+              IF (n == grid1_add) cycle
+              IF ((ABS(grid1_center_lon(grid1_add)-
+     $            grid1_center_lon(n))<delta).and.
+     $            (ABS(grid1_center_lat(grid1_add)-
+     $            grid1_center_lat(n))<delta)) THEN
+                  grid1_mask(n) = .false.
+                  WRITE(overunit, *) n, grid1_add 
+                  exit
+              END IF              
+            END DO
+        END IF
+        
+      END DO
+
+
+! Check overlapping point of the target grid
+      
+      PRINT*, 'Check overlapping point of the target grid'
+
+      WRITE(overunit, *) 'list of overlapping point of the target grid'
+
+      allocate(grid2_overlap(grid2_size))
+
+      grid2_overlap = -1
+
+      delta = epsilon(1.)
+
+      do grid2_add = 1,grid2_size
+
+        IF ((grid2_overlap(grid2_add)==-1).and.(grid2_mask(grid2_add)))
+     $      THEN
+            DO n = grid2_add, grid2_size
+              IF (n == grid2_add) cycle
+              IF ((ABS(grid2_center_lon(grid2_add)-
+     $            grid2_center_lon(n))<delta).and.
+     $            (ABS(grid2_center_lat(grid2_add)-
+     $            grid2_center_lat(n))<delta)) THEN
+                  grid2_overlap(n) = grid2_add
+                  grid2_overlap(grid2_add) = n            
+                  grid2_mask(n) = .false.
+                  WRITE(overunit, *) n, grid2_add 
+                  exit
+              END IF              
+            END DO
+        ELSE
+            grid2_overlap(grid2_add) = -1
+        END IF
+
+      END DO
+
+      CALL release_UNIT(overunit)
+
+! Sweeps
+
+      print *,'grid1 sweep '
+      do grid1_add = 1,grid1_size
+
+        !***
+        !*** restrict searches first using search bins
+        !***
+
+        call timer_start(1)
+        min_add = grid2_size
+        max_add = 1
+        do n=1,num_srch_bins
+          if (grid1_add >= bin_addr1(1,n) .and.
+     &        grid1_add <= bin_addr1(2,n)) then
+            min_add = min(min_add, bin_addr2(1,n))
+            max_add = max(max_add, bin_addr2(2,n))
+          endif
+        end do
+
+        !***
+        !*** further restrict searches using bounding boxes
+        !***
+
+        num_srch_cells = 0
+        do grid2_add = min_add,max_add
+          srch_mask(grid2_add) = (grid2_bound_box(1,grid2_add) <= 
+     &                            grid1_bound_box(2,grid1_add)) .and.
+     &                           (grid2_bound_box(2,grid2_add) >= 
+     &                            grid1_bound_box(1,grid1_add)) .and.
+     &                           (grid2_bound_box(3,grid2_add) <= 
+     &                            grid1_bound_box(4,grid1_add)) .and.
+     &                           (grid2_bound_box(4,grid2_add) >= 
+     &                            grid1_bound_box(3,grid1_add))
+
+          if (srch_mask(grid2_add)) num_srch_cells = num_srch_cells+1
+        end do
+
+        !***
+        !*** create search arrays
+        !***
+
+        allocate(srch_add(num_srch_cells),
+     &           srch_corner_lat(grid2_corners,num_srch_cells),
+     &           srch_corner_lon(grid2_corners,num_srch_cells))
+
+        n = 0
+        gather1: do grid2_add = min_add,max_add
+          if (srch_mask(grid2_add)) then
+            n = n+1
+            srch_add(n) = grid2_add
+            srch_corner_lat(:,n) = grid2_corner_lat(:,grid2_add)
+            srch_corner_lon(:,n) = grid2_corner_lon(:,grid2_add)
+          endif
+        end do gather1
+        call timer_stop(1)
+
+        !***
+        !*** integrate around this cell
+        !***
+
+        do corner = 1,grid1_corners
+          next_corn = mod(corner,grid1_corners) + 1
+
+          !***
+          !*** define endpoints of the current segment
+          !***
+
+          beglat = grid1_corner_lat(corner,grid1_add)
+          beglon = grid1_corner_lon(corner,grid1_add)
+          endlat = grid1_corner_lat(next_corn,grid1_add)
+          endlon = grid1_corner_lon(next_corn,grid1_add)
+          lrevers = .false.
+
+          !***
+          !*** to ensure exact path taken during both
+          !*** sweeps, always integrate segments in the same 
+          !*** direction (SW to NE).
+          !***
+
+          if ((endlat < beglat) .or.
+     &        (endlat == beglat .and. endlon < beglon)) then 
+              beglat = grid1_corner_lat(next_corn,grid1_add)
+              beglon = grid1_corner_lon(next_corn,grid1_add)
+              endlat = grid1_corner_lat(corner,grid1_add)
+              endlon = grid1_corner_lon(corner,grid1_add)
+              lrevers = .true.
+          ENDIF
+          begseg(1) = beglat
+          begseg(2) = beglon
+          lbegin = .true.
+          num_subseg = 0
+
+          !***
+          !*** if this is a constant-longitude segment, skip the rest 
+          !*** since the line integral contribution will be zero.
+          !***
+
+          if (endlon /= beglon) then
+          !***
+          !*** integrate along this segment, detecting intersections 
+          !*** and computing the line integral for each sub-segment
+          !***
+
+              do while (beglat /= endlat .or. beglon /= endlon)
+              !***
+              !*** prevent infinite loops if integration gets stuck
+              !*** near cell or threshold boundary
+              !***
+
+                num_subseg = num_subseg + 1
+                if (num_subseg > max_subseg) then              
+                    stop 
+     &                 'integration stalled: num_subseg exceeded limit'
+                endif
+
+                !***
+                !*** find next intersection of this segment with a grid
+                !*** line on grid 2.
+                !***
+
+                call timer_start(2)
+                call intersection(grid2_add,intrsct_lat,intrsct_lon,
+     &              lcoinc, beglat, beglon, endlat, endlon, begseg, 
+     &              lbegin, lrevers)
+                call timer_stop(2)
+                lbegin = .false.
+
+                !***
+                !*** compute line integral for this subsegment.
+                !***
+
+                call timer_start(3)
+                if (grid2_add /= 0) THEN
+                    call line_integral(weights, num_wts,
+     &                         beglon, intrsct_lon, beglat, intrsct_lat,
+     &                         grid1_center_lon(grid1_add),
+     &                         grid2_center_lon(grid2_add))
+                else
+                    call line_integral(weights, num_wts,
+     &                         beglon, intrsct_lon, beglat, intrsct_lat,
+     &                         grid1_center_lon(grid1_add),
+     &                         grid1_center_lon(grid1_add))
+                endif
+                call timer_stop(3)
+
+                !***
+                !*** if integrating in reverse order, change
+                !*** sign of weights
+                !***
+
+                if (lrevers) then
+                    weights = -weights
+                endif
+                !***
+                !*** store the appropriate addresses and weights. 
+                !*** also add contributions to cell areas and centroids.
+                !***
+                if (grid2_add /= 0) then
+                    if (grid1_mask(grid1_add)) then
+                        call timer_start(4)
+                        call store_link_cnsrv(grid1_add, grid2_add, 
+     &                      weights)
+                        IF (grid2_overlap(grid2_add)/=-1) then
+                            call store_link_cnsrv(grid1_add,
+     $                          grid2_overlap(grid2_add), weights)
+                        ENDIF
+                        call timer_stop(4)
+                        grid1_frac(grid1_add) = grid1_frac(grid1_add) 
+     &                      + weights(1)
+                        grid2_frac(grid2_add) = grid2_frac(grid2_add) 
+     &                      + weights(num_wts+1)
+                        IF (grid2_overlap(grid2_add)/=-1)
+     $                      grid2_frac(grid2_overlap(grid2_add)) =
+     $                      grid2_frac(grid2_overlap(grid2_add)) +
+     $                      weights(num_wts+1)
+                    else if (lfracnnei) THEN
+                        weights = 0  
+                        call store_link_cnsrv(grid1_add, 
+     $                      grid2_add, weights)
+                    endif
+                endif
+
+                grid1_area(grid1_add) = grid1_area(grid1_add) 
+     &              + weights(1)
+                grid1_centroid_lat(grid1_add) = 
+     &              grid1_centroid_lat(grid1_add) + weights(2)
+                grid1_centroid_lon(grid1_add) = 
+     &              grid1_centroid_lon(grid1_add) + weights(3)
+
+                !***
+                !*** reset beglat and beglon for next subsegment.
+                !***
+
+                beglat = intrsct_lat
+                beglon = intrsct_lon
+
+              end do
+
+          endif
+
+          !***
+          !*** end of segment
+          !***
+
+        end do
+
+        !***
+        !*** finished with this cell: deallocate search array and
+        !*** start on next cell
+
+        deallocate(srch_add, srch_corner_lat, srch_corner_lon)
+
+      end do
+
+      deallocate(srch_mask)
+ 
+      print *,'grid1 end sweep '
+
+!-----------------------------------------------------------------------
+!
+!     integrate around each cell on grid2
+!
+!-----------------------------------------------------------------------
+
+      allocate(srch_mask(grid1_size))
+
+      print *,'grid2 sweep '
+      do grid2_add = 1,grid2_size
+
+        !***
+        !*** restrict searches first using search bins
+        !***
+
+        call timer_start(5)
+        min_add = grid1_size
+        max_add = 1
+        do n=1,num_srch_bins
+          if (grid2_add >= bin_addr2(1,n) .and.
+     &        grid2_add <= bin_addr2(2,n)) then
+            min_add = min(min_add, bin_addr1(1,n))
+            max_add = max(max_add, bin_addr1(2,n))
+          endif
+        end do
+
+        !***
+        !*** further restrict searches using bounding boxes
+        !***
+
+        num_srch_cells = 0
+        do grid1_add = min_add, max_add
+          srch_mask(grid1_add) = (grid1_bound_box(1,grid1_add) <= 
+     &                            grid2_bound_box(2,grid2_add)) .and.
+     &                           (grid1_bound_box(2,grid1_add) >= 
+     &                            grid2_bound_box(1,grid2_add)) .and.
+     &                           (grid1_bound_box(3,grid1_add) <= 
+     &                            grid2_bound_box(4,grid2_add)) .and.
+     &                           (grid1_bound_box(4,grid1_add) >= 
+     &                            grid2_bound_box(3,grid2_add))
+
+          if (srch_mask(grid1_add)) num_srch_cells = num_srch_cells+1
+        end DO
+
+        allocate(srch_add(num_srch_cells),
+     &           srch_corner_lat(grid1_corners,num_srch_cells),
+     &           srch_corner_lon(grid1_corners,num_srch_cells))
+
+        n = 0
+        gather2: do grid1_add = min_add,max_add
+          if (srch_mask(grid1_add)) then
+            n = n+1
+            srch_add(n) = grid1_add
+            srch_corner_lat(:,n) = grid1_corner_lat(:,grid1_add)
+            srch_corner_lon(:,n) = grid1_corner_lon(:,grid1_add)
+          endif
+        end do gather2
+        call timer_stop(5)
+
+        !***
+        !*** integrate around this cell
+        !***
+
+!        full = .false.
+!        do grid1_add = min_add,max_add
+!          if (grid1_mask(grid1_add)) full = .true.
+!        end do
+!        if (full) then
+
+        do corner = 1,grid2_corners
+          next_corn = mod(corner,grid2_corners) + 1
+
+          beglat = grid2_corner_lat(corner,grid2_add)
+          beglon = grid2_corner_lon(corner,grid2_add)
+          endlat = grid2_corner_lat(next_corn,grid2_add)
+          endlon = grid2_corner_lon(next_corn,grid2_add)
+          lrevers = .false.
+
+          !***
+          !*** to ensure exact path taken during both
+          !*** sweeps, always integrate in the same direction
+          !***
+
+          if ((endlat < beglat) .or.
+     &        (endlat == beglat .and. endlon < beglon)) then 
+            beglat = grid2_corner_lat(next_corn,grid2_add)
+            beglon = grid2_corner_lon(next_corn,grid2_add)
+            endlat = grid2_corner_lat(corner,grid2_add)
+            endlon = grid2_corner_lon(corner,grid2_add)
+            lrevers = .true.
+          endif
+          begseg(1) = beglat
+          begseg(2) = beglon
+          lbegin = .true.
+
+          !***
+          !*** if this is a constant-longitude segment, skip the rest 
+          !*** since the line integral contribution will be zero.
+          !***
+
+          if (endlon /= beglon) then
+          num_subseg = 0
+
+          !***
+          !*** integrate along this segment, detecting intersections 
+          !*** and computing the line integral for each sub-segment
+          !***
+
+          do while (beglat /= endlat .or. beglon /= endlon)
+
+            !***
+            !*** prevent infinite loops if integration gets stuck
+            !*** near cell or threshold boundary
+            !***
+
+            num_subseg = num_subseg + 1
+            if (num_subseg > max_subseg) then
+              stop 'integration stalled: num_subseg exceeded limit'
+            endif
+
+            !***
+            !*** find next intersection of this segment with a line 
+            !*** on grid 2.
+            !***
+
+            call timer_start(6)
+            call intersection(grid1_add,intrsct_lat,intrsct_lon,lcoinc,
+     &                        beglat, beglon, endlat, endlon, begseg,
+     &                        lbegin, lrevers)
+            call timer_stop(6)
+            lbegin = .false.
+
+            !***
+            !*** compute line integral for this subsegment.
+            !***
+
+            call timer_start(7)
+            if (grid1_add /= 0) then
+              call line_integral(weights, num_wts,
+     &                        beglon, intrsct_lon, beglat, intrsct_lat,
+     &                         grid1_center_lon(grid1_add),
+     &                         grid2_center_lon(grid2_add))
+            else
+              call line_integral(weights, num_wts,
+     &                        beglon, intrsct_lon, beglat, intrsct_lat,
+     &                         grid2_center_lon(grid2_add),
+     &                         grid2_center_lon(grid2_add))
+            endif
+            call timer_stop(7)
+
+            if (lrevers) then
+              weights = -weights
+            endif
+            !***
+            !*** store the appropriate addresses and weights. 
+            !*** also add contributions to cell areas and centroids.
+            !*** if there is a coincidence, do not store weights
+            !*** because they have been captured in the previous loop.
+            !*** the grid1 mask is the master mask
+            !***
+
+            if (.not. lcoinc .and. grid1_add /= 0) then
+              if (grid1_mask(grid1_add)) then
+                  call timer_start(8)
+                  call store_link_cnsrv(grid1_add, grid2_add, weights)
+                  call timer_stop(8)
+                  grid1_frac(grid1_add) = grid1_frac(grid1_add) + 
+     &                                  weights(1)
+                  grid2_frac(grid2_add) = grid2_frac(grid2_add) + 
+     &                                  weights(num_wts+1)
+              else if (lfracnnei) THEN
+                  weights = 0  
+                  call store_link_cnsrv(grid1_add, grid2_add, weights)
+              endif
+
+            endif
+
+            grid2_area(grid2_add) = grid2_area(grid2_add) + 
+     &                                      weights(num_wts+1)
+            grid2_centroid_lat(grid2_add) = 
+     &      grid2_centroid_lat(grid2_add) + weights(num_wts+2)
+            grid2_centroid_lon(grid2_add) = 
+     &      grid2_centroid_lon(grid2_add) + weights(num_wts+3)
+
+            !***
+            !*** reset beglat and beglon for next subsegment.
+            !***
+
+            beglat = intrsct_lat
+            beglon = intrsct_lon
+
+          end DO
+
+          END if
+
+          !***
+          !*** end of segment
+          !***
+
+        end do
+
+        !***
+        !*** finished with this cell: deallocate search array and
+        !*** start on next cell
+
+        deallocate(srch_add, srch_corner_lat, srch_corner_lon)
+
+      end do
+
+      deallocate(srch_mask)
+      deallocate(grid2_overlap)
+
+      print *,'grid2 end sweep '
+
+!-----------------------------------------------------------------------
+!
+!     correct for situations where N/S pole not explicitly included in
+!     grid (i.e. as a grid corner point). if pole is missing from only
+!     one grid, need to correct only the area and centroid of that 
+!     grid.  if missing from both, do complete weight calculation.
+!
+!-----------------------------------------------------------------------
+
+      !*** North Pole
+      weights(1) =  pi2
+      weights(2) =  pi*pi
+      weights(3) =  zero
+      weights(4) =  pi2
+      weights(5) =  pi*pi
+      weights(6) =  zero
+
+      grid1_add = 0
+      pole_loop1: do n=1,grid1_size
+        if (grid1_area(n) < -three*pih .and.
+     &      grid1_center_lat(n) > zero) then
+          grid1_add = n
+          exit pole_loop1
+        endif
+      end do pole_loop1
+
+      grid2_add = 0
+      pole_loop2: do n=1,grid2_size
+        if (grid2_area(n) < -three*pih .and.
+     &      grid2_center_lat(n) > zero) then
+          grid2_add = n
+          exit pole_loop2
+        endif
+      end do pole_loop2
+
+      if (grid1_add /=0) then
+        grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1)
+        grid1_centroid_lat(grid1_add) = 
+     &  grid1_centroid_lat(grid1_add) + weights(2)
+        grid1_centroid_lon(grid1_add) =
+     &  grid1_centroid_lon(grid1_add) + weights(3)
+      endif
+
+      if (grid2_add /=0) then
+        grid2_area(grid2_add) = grid2_area(grid2_add) + 
+     &                                  weights(num_wts+1)
+        grid2_centroid_lat(grid2_add) = 
+     &  grid2_centroid_lat(grid2_add) + weights(num_wts+2)
+        grid2_centroid_lon(grid2_add) =
+     &  grid2_centroid_lon(grid2_add) + weights(num_wts+3)
+      endif
+
+      if (grid1_add /= 0 .and. grid2_add /=0) then
+        call store_link_cnsrv(grid1_add, grid2_add, weights)
+        grid1_frac(grid1_add) = grid1_frac(grid1_add) + 
+     &                          weights(1)
+        grid2_frac(grid2_add) = grid2_frac(grid2_add) + 
+     &                          weights(num_wts+1)
+      endif
+
+      !*** South Pole
+      weights(1) =  pi2
+      weights(2) = -pi*pi
+      weights(3) =  zero
+      weights(4) =  pi2
+      weights(5) = -pi*pi
+      weights(6) =  zero
+
+      grid1_add = 0
+      pole_loop3: do n=1,grid1_size
+        if (grid1_area(n) < -three*pih .and.
+     &      grid1_center_lat(n) < zero) then
+          grid1_add = n
+          exit pole_loop3
+        endif
+      end do pole_loop3
+
+      grid2_add = 0
+      pole_loop4: do n=1,grid2_size
+        if (grid2_area(n) < -three*pih .and.
+     &      grid2_center_lat(n) < zero) then
+          grid2_add = n
+          exit pole_loop4
+        endif
+      end do pole_loop4
+
+      if (grid1_add /=0) then
+        grid1_area(grid1_add) = grid1_area(grid1_add) + weights(1)
+        grid1_centroid_lat(grid1_add) = 
+     &  grid1_centroid_lat(grid1_add) + weights(2)
+        grid1_centroid_lon(grid1_add) =
+     &  grid1_centroid_lon(grid1_add) + weights(3)
+      endif
+
+      if (grid2_add /=0) then
+        grid2_area(grid2_add) = grid2_area(grid2_add) + 
+     &                                  weights(num_wts+1)
+        grid2_centroid_lat(grid2_add) = 
+     &  grid2_centroid_lat(grid2_add) + weights(num_wts+2)
+        grid2_centroid_lon(grid2_add) =
+     &  grid2_centroid_lon(grid2_add) + weights(num_wts+3)
+      endif
+
+      if (grid1_add /= 0 .and. grid2_add /=0) then
+        call store_link_cnsrv(grid1_add, grid2_add, weights)
+
+        grid1_frac(grid1_add) = grid1_frac(grid1_add) + 
+     &                          weights(1)
+        grid2_frac(grid2_add) = grid2_frac(grid2_add) + 
+     &                          weights(num_wts+1)
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     finish centroid computation
+!
+!-----------------------------------------------------------------------
+
+      where (grid1_area /= zero)
+        grid1_centroid_lat = grid1_centroid_lat/grid1_area
+        grid1_centroid_lon = grid1_centroid_lon/grid1_area
+      end where
+
+      where (grid2_area /= zero)
+        grid2_centroid_lat = grid2_centroid_lat/grid2_area
+        grid2_centroid_lon = grid2_centroid_lon/grid2_area
+      end where
+
+!-----------------------------------------------------------------------
+!
+!     include centroids in weights and normalize using destination
+!     area if requested
+!
+!-----------------------------------------------------------------------
+
+      do n=1,num_links_map1
+
+        grid1_add = grid1_add_map1(n)
+        grid2_add = grid2_add_map1(n)
+        do nwgt=1,num_wts
+          weights(        nwgt) = wts_map1(nwgt,n)
+!          if (num_maps > 1) then
+!            weights(num_wts+nwgt) = wts_map2(nwgt,n)
+!          endif
+        end do
+
+        select case(norm_opt)
+        case (norm_opt_dstarea)
+          if (grid2_area(grid2_add) /= zero) then
+            if (luse_grid2_area) then
+              norm_factor = one/grid2_area_in(grid2_add)
+            else
+              norm_factor = one/grid2_area(grid2_add)
+            endif
+          else
+            norm_factor = zero
+          endif
+        case (norm_opt_frcarea)
+          if (grid2_frac(grid2_add) /= zero) then
+            if (luse_grid2_area) then
+              norm_factor = grid2_area(grid2_add)/
+     &                     (grid2_frac(grid2_add)*
+     &                      grid2_area_in(grid2_add))
+            else
+              norm_factor = one/grid2_frac(grid2_add)
+            endif
+          else
+            norm_factor = zero
+          endif
+        case (norm_opt_none)
+          norm_factor = one
+        end select
+
+        wts_map1(1,n) =  weights(1)*norm_factor
+        wts_map1(2,n) = (weights(2) - weights(1)*
+     &                              grid1_centroid_lat(grid1_add))*
+     &                              norm_factor
+        wts_map1(3,n) = (weights(3) - weights(1)*
+     &                              grid1_centroid_lon(grid1_add))*
+     &                              norm_factor
+
+!        if (num_maps > 1) then
+!          select case(norm_opt)
+!          case (norm_opt_dstarea)
+!            if (grid1_area(grid1_add) /= zero) then
+!              if (luse_grid1_area) then
+!                norm_factor = one/grid1_area_in(grid1_add)
+!              else
+!                norm_factor = one/grid1_area(grid1_add)
+!              endif
+!            else
+!              norm_factor = zero
+!            endif
+!          case (norm_opt_frcarea)
+!            if (grid1_frac(grid1_add) /= zero) then
+!              if (luse_grid1_area) then
+!                norm_factor = grid1_area(grid1_add)/
+!     &                       (grid1_frac(grid1_add)*
+!     &                        grid1_area_in(grid1_add))
+!              else
+!                norm_factor = one/grid1_frac(grid1_add)
+!              endif
+!            else
+!              norm_factor = zero
+!            endif
+!          case (norm_opt_none)
+!            norm_factor = one
+!          end select
+!
+!          wts_map2(1,n) =  weights(num_wts+1)*norm_factor
+!          wts_map2(2,n) = (weights(num_wts+2) - weights(num_wts+1)*
+!     &                                grid2_centroid_lat(grid2_add))*
+!     &                                norm_factor
+!          wts_map2(3,n) = (weights(num_wts+3) - weights(num_wts+1)*
+!     &                                grid2_centroid_lon(grid2_add))*
+!     &                                norm_factor
+!      endif
+
+      end do
+
+      print *, 'Total number of links = ',num_links_map1
+
+      where (grid1_area /= zero) grid1_frac = grid1_frac/grid1_area
+      where (grid2_area /= zero) grid2_frac = grid2_frac/grid2_area
+
+!-----------------------------------------------------------------------
+!
+!     perform some error checking on final weights
+!
+!-----------------------------------------------------------------------
+
+      grid2_centroid_lat = zero
+      grid2_centroid_lon = zero
+
+      do n=1,grid1_size
+        if (grid1_area(n) < -.01) then
+          print *,'Grid 1 area error: n, area, mask ='
+     &          ,n,grid1_area(n), grid1_mask(n)
+        endif
+        if (grid1_centroid_lat(n) < -pih-.01 .or.
+     &      grid1_centroid_lat(n) >  pih+.01) then
+            print *,'Grid 1 centroid lat error: n, centroid_lat, mask='
+     &          ,n,grid1_centroid_lat(n), grid1_mask(n)
+        endif
+        grid1_centroid_lat(n) = zero
+        grid1_centroid_lon(n) = zero
+      end do
+
+      do n=1,grid2_size
+        if (grid2_area(n) < -.01) then
+            print *,'Grid 2 area error:  n, area, mask ='
+     &      ,n,grid2_area(n), grid2_mask(n)
+        endif
+        if (grid2_centroid_lat(n) < -pih-.01 .or.
+     &      grid2_centroid_lat(n) >  pih+.01) then
+          print *,'Grid 2 centroid lat error: n, centroid_lat, mask='
+     &          ,n,grid2_centroid_lat(n), grid2_mask(n)
+        endif
+        grid2_centroid_lat(n) = zero
+        grid2_centroid_lon(n) = zero
+      end do
+
+      do n=1,num_links_map1
+        grid1_add = grid1_add_map1(n)
+        grid2_add = grid2_add_map1(n)
+        
+        if (wts_map1(1,n) < -.01) then
+          print *,'Map 1 weight < 0 '
+          PRINT *,
+     &        'grid1_add, grid2_add, wts_map1, grid1_mask, grid2_mask',
+     &        grid1_add, grid2_add, wts_map1(1,n), 
+     &        grid1_mask(grid1_add), grid2_mask(grid2_add) 
+        endif
+        if (norm_opt /= norm_opt_none .and. wts_map1(1,n) > 1.01) then
+          print *,'Map 1 weight > 1 '
+          PRINT *,
+     &        'grid1_add, grid2_add, wts_map1, grid1_mask, grid2_mask',
+     &        grid1_add, grid2_add, wts_map1(1,n), 
+     &        grid1_mask(grid1_add), grid2_mask(grid2_add) 
+        endif
+        grid2_centroid_lat(grid2_add) = 
+     &  grid2_centroid_lat(grid2_add) + wts_map1(1,n)
+
+!        if (num_maps > 1) then
+!          if (wts_map2(1,n) < -.01) then
+!            print *,'Map 2 weight < 0 '
+!            PRINT *,
+!     &          'grid1_add,grid2_add, wts_map2, grid1_mask, grid2_mask',
+!     &          grid1_add, grid2_add, wts_map2(1,n), 
+!     &          grid1_mask(grid1_add), grid2_mask(grid2_add) 
+!          endif
+!          if (norm_opt /= norm_opt_none .and. wts_map2(1,n) > 1.01) then
+!            print *,'Map 2 weight < 0 '
+!            PRINT *,
+!     &          'grid1_add,grid2_add,wts_map2, grid1_mask,grid2_mask',
+!     &          grid1_add, grid2_add, wts_map2(1,n), 
+!     &          grid1_mask(grid1_add), grid2_mask(grid2_add) 
+!          endif
+!          grid1_centroid_lat(grid1_add) = 
+!     &    grid1_centroid_lat(grid1_add) + wts_map2(1,n)
+!      endif
+      end do
+
+      do n=1,grid2_size
+        select case(norm_opt)
+        case (norm_opt_dstarea)
+          norm_factor = grid2_frac(grid2_add)
+        case (norm_opt_frcarea)
+          norm_factor = one
+        case (norm_opt_none)
+          if (luse_grid2_area) then
+            norm_factor = grid2_area_in(grid2_add)
+          else
+            norm_factor = grid2_area(grid2_add)
+          endif
+        end select
+        if (abs(grid2_centroid_lat(grid2_add)-norm_factor) > .01) then
+          print *,
+     &'Error sum wts map1:grid2_add,grid2_centroid_lat,norm_factor='
+     &,grid2_add,grid2_centroid_lat(grid2_add),
+     &norm_factor,grid2_mask(grid2_add)
+        endif
+      end do
+
+!      if (num_maps > 1) then
+!        do n=1,grid1_size
+!          select case(norm_opt)
+!          case (norm_opt_dstarea)
+!            norm_factor = grid1_frac(grid1_add)
+!          case (norm_opt_frcarea)
+!            norm_factor = one
+!          case (norm_opt_none)
+!            if (luse_grid1_area) then
+!              norm_factor = grid1_area_in(grid1_add)
+!            else
+!              norm_factor = grid1_area(grid1_add)
+!            endif
+!          end select
+!          if (abs(grid1_centroid_lat(grid1_add)-norm_factor) > .01) then
+!            print *,
+!     &'Error sum wts map2:grid1_add,grid1_centroid_lat,norm_factor='
+!     &,grid1_add,grid1_centroid_lat(grid1_add),
+!     &norm_factor,grid1_mask(grid1_add)
+!          endif
+!        end do
+!      endif
+
+!-----------------------------------------------------------------------
+!
+!     deallocate allocated arrays
+!
+!----------------------------------------------------------------------- 
+
+      deallocate (grid1_centroid_lat, grid1_centroid_lon,
+     &            grid2_centroid_lat, grid2_centroid_lon)
+
+!-----------------------------------------------------------------------
+
+      end subroutine remap_conserv
+
+!***********************************************************************
+
+      subroutine intersection(location,intrsct_lat,intrsct_lon,lcoinc,
+     &                        beglat, beglon, endlat, endlon, begseg,
+     &                        lbegin, lrevers)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the next intersection of a destination grid 
+!     line with the line segment given by beglon, endlon, etc.
+!     a coincidence flag is returned if the segment is entirely 
+!     coincident with an ocean grid line.  the cells in which to search
+!     for an intersection must have already been restricted in the
+!     calling routine.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     intent(in): 
+!
+!-----------------------------------------------------------------------
+
+      logical (kind=log_kind), intent(in) ::
+     &     lbegin, ! flag for first integration along this segment
+     &     lrevers ! flag whether segment integrated in reverse
+
+      real (kind=dbl_kind), intent(in) :: 
+     &     beglat, beglon,  ! beginning lat/lon endpoints for segment
+     &     endlat, endlon   ! ending    lat/lon endpoints for segment
+
+      real (kind=dbl_kind), dimension(2), intent(inout) :: 
+     &     begseg ! begin lat/lon of full segment
+
+!-----------------------------------------------------------------------
+!
+!     intent(out): 
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(out) ::
+     &        location  ! address in destination array containing this
+                        ! segment
+
+      logical (kind=log_kind), intent(out) ::
+     &        lcoinc    ! flag segments which are entirely coincident
+                        ! with a grid line
+
+      real (kind=dbl_kind), intent(out) ::
+     &     intrsct_lat, intrsct_lon ! lat/lon coords of next intersect.
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, next_n, cell, srch_corners
+
+      integer (kind=int_kind), save :: 
+     &     last_loc  ! save location when crossing threshold
+
+      logical (kind=log_kind) :: 
+     &     loutside  ! flags points outside grid
+
+      logical (kind=log_kind), save :: 
+     &     lthresh = .false.  ! flags segments crossing threshold bndy
+
+      real (kind=dbl_kind) ::
+     &     lon1, lon2,       ! local longitude variables for segment
+     &     lat1, lat2,       ! local latitude  variables for segment
+     &     grdlon1, grdlon2, ! local longitude variables for grid cell
+     &     grdlat1, grdlat2, ! local latitude  variables for grid cell
+     &     vec1_lat, vec1_lon, ! vectors and cross products used
+     &     vec2_lat, vec2_lon, ! during grid search
+     &     cross_product, 
+     &     eps, offset,        ! small offset away from intersect
+     &     s1, s2, determ,     ! variables used for linear solve to
+     &     mat1, mat2, mat3, mat4, rhs1, rhs2, ! find intersection
+     &     rl_halfpi, rl_v2lonmpi2, rl_v2lonppi2
+
+      real (kind=dbl_kind), save ::
+     &     intrsct_lat_off, intrsct_lon_off ! lat/lon coords offset 
+                                            ! for next search
+
+!-----------------------------------------------------------------------
+!
+!     initialize defaults, flags, etc.
+!
+!-----------------------------------------------------------------------
+
+      location = 0
+      lcoinc = .false.
+      intrsct_lat = endlat
+      intrsct_lon = endlon
+
+      if (num_srch_cells == 0) return
+
+      if (beglat > north_thresh .or. beglat < south_thresh) then
+
+        if (lthresh) location = last_loc
+        call pole_intersection(location,
+     &               intrsct_lat,intrsct_lon,lcoinc,lthresh,
+     &               beglat, beglon, endlat, endlon, begseg, lrevers)
+        if (lthresh) then
+          last_loc = location
+          intrsct_lat_off = intrsct_lat
+          intrsct_lon_off = intrsct_lon
+        endif
+        return
+
+      endif
+
+      loutside = .false.
+      if (lbegin) then
+        lat1 = beglat
+        lon1 = beglon
+      else
+        lat1 = intrsct_lat_off
+        lon1 = intrsct_lon_off
+      endif
+      lat2 = endlat
+      lon2 = endlon
+      if ((lon2-lon1) > three*pih) then
+        lon2 = lon2 - pi2
+      else if ((lon2-lon1) < -three*pih) then
+        lon2 = lon2 + pi2
+      endif
+      s1 = zero
+
+!-----------------------------------------------------------------------
+!
+!     search for location of this segment in ocean grid using cross
+!     product method to determine whether a point is enclosed by a cell
+!
+!-----------------------------------------------------------------------
+
+      call timer_start(12)
+      srch_corners = size(srch_corner_lat,DIM=1)
+      srch_loop: do
+
+        !***
+        !*** if last segment crossed threshold, use that location
+        !***
+
+        if (lthresh) then
+          do cell=1,num_srch_cells
+            if (srch_add(cell) == last_loc) then
+              location = last_loc
+              eps = tiny
+              exit srch_loop
+            endif
+          end do
+        endif
+
+        !***
+        !*** otherwise normal search algorithm
+        !***
+
+        cell_loop: do cell=1,num_srch_cells
+          corner_loop: do n=1,srch_corners
+            next_n = MOD(n,srch_corners) + 1
+
+            !***
+            !*** here we take the cross product of the vector making 
+            !*** up each cell side with the vector formed by the vertex
+            !*** and search point.  if all the cross products are 
+            !*** positive, the point is contained in the cell.
+            !***
+
+            vec1_lat = srch_corner_lat(next_n,cell) - 
+     &                 srch_corner_lat(n     ,cell)
+            vec1_lon = srch_corner_lon(next_n,cell) - 
+     &                 srch_corner_lon(n     ,cell)
+            vec2_lat = lat1 - srch_corner_lat(n,cell)
+            vec2_lon = lon1 - srch_corner_lon(n,cell)
+
+            !***
+            !*** if endpoint coincident with vertex, offset
+            !*** the endpoint
+            !***
+
+            if (vec2_lat == 0 .and. vec2_lon == 0) then
+              lat1 = lat1 + 1.d-10*(lat2-lat1)
+              lon1 = lon1 + 1.d-10*(lon2-lon1)
+              vec2_lat = lat1 - srch_corner_lat(n,cell)
+              vec2_lon = lon1 - srch_corner_lon(n,cell)
+            ENDIF
+
+            !***
+            !*** check for 0,2pi crossings
+            !***
+
+            if (vec1_lon >  pi) then
+              vec1_lon = vec1_lon - pi2
+            else if (vec1_lon < -pi) then
+              vec1_lon = vec1_lon + pi2
+            endif
+            if (vec2_lon >  pi) then
+              vec2_lon = vec2_lon - pi2
+            else if (vec2_lon < -pi) then
+              vec2_lon = vec2_lon + pi2
+            endif
+
+            cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat
+            !***
+            !*** if the cross product for a side is zero, the point 
+            !***   lies exactly on the side or the side is degenerate
+            !***   (zero length).  if degenerate, set the cross 
+            !***   product to a positive number.  otherwise perform 
+            !***   another cross product between the side and the 
+            !***   segment itself. 
+            !*** if this cross product is also zero, the line is 
+            !***   coincident with the cell boundary - perform the 
+            !***   dot product and only choose the cell if the dot 
+            !***   product is positive (parallel vs anti-parallel).
+            !***
+
+            if (cross_product == zero) then
+              if (vec1_lat /= zero .or. vec1_lon /= zero) then
+                vec2_lat = lat2 - lat1
+                vec2_lon = lon2 - lon1
+
+                if (vec2_lon >  pi) then
+                  vec2_lon = vec2_lon - pi2
+                else if (vec2_lon < -pi) then
+                  vec2_lon = vec2_lon + pi2
+                endif
+
+                cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat
+              else
+                cross_product = one
+              endif
+
+              if (cross_product == zero) then
+                lcoinc = .true.
+                cross_product = vec1_lon*vec2_lon + vec1_lat*vec2_lat
+                if (lrevers) cross_product = -cross_product
+              endif
+            endif
+
+            !***
+            !*** if cross product is less than zero, this cell
+            !*** doesn't work
+            !***
+
+            if (cross_product < zero) exit corner_loop
+
+          end do corner_loop
+
+          !***
+          !*** if cross products all positive, we found the location
+          !***
+
+          if (n > srch_corners) then
+            location = srch_add(cell)
+
+            !***
+            !*** if the beginning of this segment was outside the
+            !*** grid, invert the segment so the intersection found
+            !*** will be the first intersection with the grid
+            !***
+
+            if (loutside) then
+              lat2 = beglat
+              lon2 = beglon
+              location = 0
+              eps  = -tiny
+            else
+              eps  = tiny
+            endif
+
+            exit srch_loop
+          endif
+
+          !***
+          !*** otherwise move on to next cell
+          !***
+
+        end do cell_loop
+
+        !***
+        !*** if still no cell found, the point lies outside the grid.
+        !***   take some baby steps along the segment to see if any
+        !***   part of the segment lies inside the grid.  
+        !***
+
+        loutside = .true.
+        s1 = s1 + 0.001_dbl_kind
+        lat1 = beglat + s1*(endlat - beglat)
+        lon1 = beglon + s1*(lon2   - beglon)
+
+        !***
+        !*** reached the end of the segment and still outside the grid
+        !*** return no intersection
+        !***
+
+        if (s1 >= one) return
+
+      end do srch_loop
+      call timer_stop(12)
+
+!-----------------------------------------------------------------------
+!
+!     now that a cell is found, search for the next intersection.
+!     loop over sides of the cell to find intersection with side
+!     must check all sides for coincidences or intersections
+!
+!-----------------------------------------------------------------------
+
+      call timer_start(13)
+      intrsct_loop: do n=1,srch_corners
+        next_n = mod(n,srch_corners) + 1
+
+        grdlon1 = srch_corner_lon(n     ,cell)
+        grdlon2 = srch_corner_lon(next_n,cell)
+        grdlat1 = srch_corner_lat(n     ,cell)
+        grdlat2 = srch_corner_lat(next_n,cell)
+
+        !***
+        !*** set up linear system to solve for intersection
+        !***
+
+        mat1 = lat2 - lat1
+        mat2 = grdlat1 - grdlat2
+        mat3 = lon2 - lon1
+        mat4 = grdlon1 - grdlon2
+        rhs1 = grdlat1 - lat1
+        rhs2 = grdlon1 - lon1
+
+        if (mat3 >  pi) then
+          mat3 = mat3 - pi2
+        else if (mat3 < -pi) then
+          mat3 = mat3 + pi2
+        endif
+        if (mat4 >  pi) then
+          mat4 = mat4 - pi2
+        else if (mat4 < -pi) then
+          mat4 = mat4 + pi2
+        endif
+        if (rhs2 >  pi) then
+          rhs2 = rhs2 - pi2
+        else if (rhs2 < -pi) then
+          rhs2 = rhs2 + pi2
+        endif
+
+        determ = mat1*mat4 - mat2*mat3
+
+        !***
+        !*** if the determinant is zero, the segments are either 
+        !***   parallel or coincident.  coincidences were detected 
+        !***   above so do nothing.
+        !*** if the determinant is non-zero, solve for the linear 
+        !***   parameters s for the intersection point on each line 
+        !***   segment.
+        !*** if 0<s1,s2<1 then the segment intersects with this side.
+        !***   return the point of intersection (adding a small
+        !***   number so the intersection is off the grid line).
+        !***
+
+        if (abs(determ) > 1.e-30) then
+
+          s1 = (rhs1*mat4 - mat2*rhs2)/determ
+          s2 = (mat1*rhs2 - rhs1*mat3)/determ
+
+          if (s2 >= zero .and. s2 <= one .and.
+     &        s1 >  zero. and. s1 <= one) then
+
+            !***
+            !*** recompute intersection based on full segment
+            !*** so intersections are consistent for both sweeps
+            !***
+
+            if (.not. loutside) then
+              mat1 = lat2 - begseg(1)
+              mat3 = lon2 - begseg(2)
+              rhs1 = grdlat1 - begseg(1)
+              rhs2 = grdlon1 - begseg(2)
+            else
+              mat1 = begseg(1) - endlat
+              mat3 = begseg(2) - endlon
+              rhs1 = grdlat1 - endlat
+              rhs2 = grdlon1 - endlon
+            endif
+
+            if (mat3 >  pi) then
+              mat3 = mat3 - pi2
+            else if (mat3 < -pi) then
+              mat3 = mat3 + pi2
+            endif
+            if (rhs2 >  pi) then
+              rhs2 = rhs2 - pi2
+            else if (rhs2 < -pi) then
+              rhs2 = rhs2 + pi2
+            endif
+
+            determ = mat1*mat4 - mat2*mat3
+
+            !***
+            !*** sometimes due to roundoff, the previous 
+            !*** determinant is non-zero, but the lines
+            !*** are actually coincident.  if this is the
+            !*** case, skip the rest.
+            !***
+
+            if (determ /= zero) then
+              s1 = (rhs1*mat4 - mat2*rhs2)/determ
+              s2 = (mat1*rhs2 - rhs1*mat3)/determ
+
+              offset = s1 + eps/determ
+              if (offset > one) offset = one
+
+              if (.not. loutside) then
+                intrsct_lat = begseg(1) + mat1*s1
+                intrsct_lon = begseg(2) + mat3*s1
+                intrsct_lat_off = begseg(1) + mat1*offset
+                intrsct_lon_off = begseg(2) + mat3*offset
+              else
+                intrsct_lat = endlat + mat1*s1
+                intrsct_lon = endlon + mat3*s1
+                intrsct_lat_off = endlat + mat1*offset
+                intrsct_lon_off = endlon + mat3*offset
+              endif
+              exit intrsct_loop
+            endif
+
+          endif
+        endif
+
+        !***
+        !*** no intersection this side, move on to next side
+        !***
+
+      end do intrsct_loop
+      call timer_stop(13)
+
+!-----------------------------------------------------------------------
+!
+!     if the segment crosses a pole threshold, reset the intersection
+!     to be the threshold latitude.  only check if this was not a
+!     threshold segment since sometimes coordinate transform can end
+!     up on other side of threshold again.
+!
+!-----------------------------------------------------------------------
+
+      if (lthresh) then
+        if (intrsct_lat < north_thresh .or. intrsct_lat > south_thresh)
+     &      lthresh = .false.
+      else if (lat1 > zero .and. intrsct_lat > north_thresh) then
+        intrsct_lat = north_thresh + tiny
+        intrsct_lat_off = north_thresh + eps*mat1
+        s1 = (intrsct_lat - begseg(1))/mat1
+        intrsct_lon     = begseg(2) + s1*mat3
+        intrsct_lon_off = begseg(2) + (s1+eps)*mat3
+        last_loc = location
+        lthresh = .true.
+      else if (lat1 < zero .and. intrsct_lat < south_thresh) then
+        intrsct_lat = south_thresh - tiny
+        intrsct_lat_off = south_thresh + eps*mat1
+        s1 = (intrsct_lat - begseg(1))/mat1
+        intrsct_lon     = begseg(2) + s1*mat3
+        intrsct_lon_off = begseg(2) + (s1+eps)*mat3
+        last_loc = location
+        lthresh = .true.
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine intersection
+
+!***********************************************************************
+
+      subroutine pole_intersection(location,
+     &                 intrsct_lat,intrsct_lon,lcoinc,lthresh,
+     &                 beglat, beglon, endlat, endlon, begseg, lrevers)
+
+!-----------------------------------------------------------------------
+!
+!     this routine is identical to the intersection routine except
+!     that a coordinate transformation (using a Lambert azimuthal
+!     equivalent projection) is performed to treat polar cells more
+!     accurately.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     intent(in): 
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), intent(in) :: 
+     &     beglat, beglon,  ! beginning lat/lon endpoints for segment
+     &     endlat, endlon   ! ending    lat/lon endpoints for segment
+
+      real (kind=dbl_kind), dimension(2), intent(inout) :: 
+     &     begseg ! begin lat/lon of full segment
+
+      logical (kind=log_kind), intent(in) ::
+     &        lrevers   ! flag true if segment integrated in reverse
+
+!-----------------------------------------------------------------------
+!
+!     intent(out): 
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(inout) ::
+     &        location  ! address in destination array containing this
+                        ! segment -- also may contain last location on
+                        ! entry
+
+      logical (kind=log_kind), intent(out) ::
+     &        lcoinc    ! flag segment coincident with grid line
+
+      logical (kind=log_kind), intent(inout) ::
+     &        lthresh   ! flag segment crossing threshold boundary
+
+      real (kind=dbl_kind), intent(out) ::
+     &     intrsct_lat, intrsct_lon ! lat/lon coords of next intersect.
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, next_n, cell, srch_corners
+
+      logical (kind=log_kind) :: loutside ! flags points outside grid
+
+      real (kind=dbl_kind) :: pi4, rns, ! north/south conversion
+     &     x1, x2,       ! local x variables for segment
+     &     y1, y2,       ! local y variables for segment
+     &     begx, begy,   ! beginning x,y variables for segment
+     &     endx, endy,   ! beginning x,y variables for segment
+     &     begsegx, begsegy,   ! beginning x,y variables for segment
+     &     grdx1, grdx2, ! local x variables for grid cell
+     &     grdy1, grdy2, ! local y variables for grid cell
+     &     vec1_y, vec1_x, ! vectors and cross products used
+     &     vec2_y, vec2_x, ! during grid search
+     &     cross_product, eps, ! eps=small offset away from intersect
+     &     s1, s2, determ,     ! variables used for linear solve to
+     &     mat1, mat2, mat3, mat4, rhs1, rhs2  ! find intersection
+
+      real (kind=dbl_kind), dimension(:,:), allocatable ::
+     &     srch_corner_x,  ! x of each corner of srch cells
+     &     srch_corner_y   ! y of each corner of srch cells
+
+      !***
+      !*** save last intersection to avoid roundoff during coord
+      !*** transformation
+      !***
+
+      logical (kind=log_kind), save :: luse_last = .false.
+
+      real (kind=dbl_kind), save :: 
+     &     intrsct_x, intrsct_y  ! x,y for intersection
+
+      !***
+      !*** variables necessary if segment manages to hit pole
+      !***
+
+      integer (kind=int_kind), save :: 
+     &     avoid_pole_count = 0  ! count attempts to avoid pole
+
+      real (kind=dbl_kind), save :: 
+     &     avoid_pole_offset = tiny  ! endpoint offset to avoid pole
+
+!-----------------------------------------------------------------------
+!
+!     initialize defaults, flags, etc.
+!
+!-----------------------------------------------------------------------
+
+      if (.not. lthresh) location = 0
+      lcoinc = .false.
+      intrsct_lat = endlat
+      intrsct_lon = endlon
+
+      loutside = .false.
+      s1 = zero
+
+!-----------------------------------------------------------------------
+!
+!     convert coordinates
+!
+!-----------------------------------------------------------------------
+
+      allocate(srch_corner_x(size(srch_corner_lat,DIM=1),
+     &                       size(srch_corner_lat,DIM=2)),
+     &         srch_corner_y(size(srch_corner_lat,DIM=1),
+     &                       size(srch_corner_lat,DIM=2)))
+
+      if (beglat > zero) then
+        pi4 = quart*pi
+        rns = one
+      else
+        pi4 = -quart*pi
+        rns = -one
+      endif
+
+      if (luse_last) then
+        x1 = intrsct_x
+        y1 = intrsct_y
+      else
+        x1 = rns*two*sin(pi4 - half*beglat)*cos(beglon)
+        y1 =     two*sin(pi4 - half*beglat)*sin(beglon)
+        luse_last = .true.
+      endif
+      x2 = rns*two*sin(pi4 - half*endlat)*cos(endlon)
+      y2 =     two*sin(pi4 - half*endlat)*sin(endlon)
+      srch_corner_x = rns*two*sin(pi4 - half*srch_corner_lat)*
+     &                        cos(srch_corner_lon)
+      srch_corner_y =     two*sin(pi4 - half*srch_corner_lat)*
+     &                        sin(srch_corner_lon)
+
+      begx = x1
+      begy = y1
+      endx = x2
+      endy = y2
+      begsegx = rns*two*sin(pi4 - half*begseg(1))*cos(begseg(2))
+      begsegy =     two*sin(pi4 - half*begseg(1))*sin(begseg(2))
+      intrsct_x = endx
+      intrsct_y = endy
+
+!-----------------------------------------------------------------------
+!
+!     search for location of this segment in ocean grid using cross
+!     product method to determine whether a point is enclosed by a cell
+!
+!-----------------------------------------------------------------------
+
+      call timer_start(12)
+      srch_corners = size(srch_corner_lat,DIM=1)
+      srch_loop: do
+
+        !***
+        !*** if last segment crossed threshold, use that location
+        !***
+
+        if (lthresh) then
+          do cell=1,num_srch_cells
+            if (srch_add(cell) == location) then
+              eps = tiny
+              exit srch_loop
+            endif
+          end do
+        endif
+
+        !***
+        !*** otherwise normal search algorithm
+        !***
+
+        cell_loop: do cell=1,num_srch_cells
+          corner_loop: do n=1,srch_corners
+            next_n = MOD(n,srch_corners) + 1
+
+            !***
+            !*** here we take the cross product of the vector making 
+            !*** up each cell side with the vector formed by the vertex
+            !*** and search point.  if all the cross products are 
+            !*** positive, the point is contained in the cell.
+            !***
+
+            vec1_x = srch_corner_x(next_n,cell) - 
+     &               srch_corner_x(n     ,cell)
+            vec1_y = srch_corner_y(next_n,cell) - 
+     &               srch_corner_y(n     ,cell)
+            vec2_x = x1 - srch_corner_x(n,cell)
+            vec2_y = y1 - srch_corner_y(n,cell)
+
+            !***
+            !*** if endpoint coincident with vertex, offset
+            !*** the endpoint
+            !***
+
+            if (vec2_x == 0 .and. vec2_y == 0) then
+              x1 = x1 + 1.d-10*(x2-x1)
+              y1 = y1 + 1.d-10*(y2-y1)
+              vec2_x = x1 - srch_corner_x(n,cell)
+              vec2_y = y1 - srch_corner_y(n,cell)
+            endif
+
+            cross_product = vec1_x*vec2_y - vec2_x*vec1_y
+
+            !***
+            !*** if the cross product for a side is zero, the point 
+            !***   lies exactly on the side or the length of a side
+            !***   is zero.  if the length is zero set det > 0.
+            !***   otherwise, perform another cross 
+            !***   product between the side and the segment itself. 
+            !*** if this cross product is also zero, the line is 
+            !***   coincident with the cell boundary - perform the 
+            !***   dot product and only choose the cell if the dot 
+            !***   product is positive (parallel vs anti-parallel).
+            !***
+
+            if (cross_product == zero) then
+              if (vec1_x /= zero .or. vec1_y /= 0) then
+                vec2_x = x2 - x1
+                vec2_y = y2 - y1
+                cross_product = vec1_x*vec2_y - vec2_x*vec1_y
+              else
+                cross_product = one
+              endif
+
+              if (cross_product == zero) then
+                lcoinc = .true.
+                cross_product = vec1_x*vec2_x + vec1_y*vec2_y
+                if (lrevers) cross_product = -cross_product
+              endif
+            endif
+
+            !***
+            !*** if cross product is less than zero, this cell
+            !*** doesn't work
+            !***
+
+            if (cross_product < zero) exit corner_loop
+
+          end do corner_loop
+
+          !***
+          !*** if cross products all positive, we found the location
+          !***
+
+          if (n > srch_corners) then
+            location = srch_add(cell)
+
+            !***
+            !*** if the beginning of this segment was outside the
+            !*** grid, invert the segment so the intersection found
+            !*** will be the first intersection with the grid
+            !***
+
+            if (loutside) then
+              x2 = begx
+              y2 = begy
+              location = 0
+              eps  = -tiny
+            else
+              eps  = tiny
+            endif
+
+            exit srch_loop
+          endif
+
+          !***
+          !*** otherwise move on to next cell
+          !***
+
+        end do cell_loop
+
+        !***
+        !*** if no cell found, the point lies outside the grid.
+        !***   take some baby steps along the segment to see if any
+        !***   part of the segment lies inside the grid.  
+        !***
+
+        loutside = .true.
+        s1 = s1 + 0.001_dbl_kind
+        x1 = begx + s1*(x2 - begx)
+        y1 = begy + s1*(y2 - begy)
+
+        !***
+        !*** reached the end of the segment and still outside the grid
+        !*** return no intersection
+        !***
+
+        if (s1 >= one) then
+          deallocate(srch_corner_x, srch_corner_y)
+          luse_last = .false.
+          return
+        endif
+
+      end do srch_loop
+      call timer_stop(12)
+
+!-----------------------------------------------------------------------
+!
+!     now that a cell is found, search for the next intersection.
+!     loop over sides of the cell to find intersection with side
+!     must check all sides for coincidences or intersections
+!
+!-----------------------------------------------------------------------
+
+      call timer_start(13)
+      intrsct_loop: do n=1,srch_corners
+        next_n = mod(n,srch_corners) + 1
+
+        grdy1 = srch_corner_y(n     ,cell)
+        grdy2 = srch_corner_y(next_n,cell)
+        grdx1 = srch_corner_x(n     ,cell)
+        grdx2 = srch_corner_x(next_n,cell)
+
+        !***
+        !*** set up linear system to solve for intersection
+        !***
+
+        mat1 = x2 - x1
+        mat2 = grdx1 - grdx2
+        mat3 = y2 - y1
+        mat4 = grdy1 - grdy2
+        rhs1 = grdx1 - x1
+        rhs2 = grdy1 - y1
+
+        determ = mat1*mat4 - mat2*mat3
+
+        !***
+        !*** if the determinant is zero, the segments are either 
+        !***   parallel or coincident or one segment has zero length.  
+        !***   coincidences were detected above so do nothing.
+        !*** if the determinant is non-zero, solve for the linear 
+        !***   parameters s for the intersection point on each line 
+        !***   segment.
+        !*** if 0<s1,s2<1 then the segment intersects with this side.
+        !***   return the point of intersection (adding a small
+        !***   number so the intersection is off the grid line).
+        !***
+
+        if (abs(determ) > 1.e-30) then
+
+          s1 = (rhs1*mat4 - mat2*rhs2)/determ
+          s2 = (mat1*rhs2 - rhs1*mat3)/determ
+
+          if (s2 >= zero .and. s2 <= one .and.
+     &        s1 >  zero. and. s1 <= one) then
+
+            !***
+            !*** recompute intersection using entire segment
+            !*** for consistency between sweeps
+            !***
+
+            if (.not. loutside) then
+              mat1 = x2 - begsegx
+              mat3 = y2 - begsegy
+              rhs1 = grdx1 - begsegx
+              rhs2 = grdy1 - begsegy
+            else 
+              mat1 = x2 - endx
+              mat3 = y2 - endy
+              rhs1 = grdx1 - endx
+              rhs2 = grdy1 - endy
+            endif
+
+            determ = mat1*mat4 - mat2*mat3
+
+            !***
+            !*** sometimes due to roundoff, the previous 
+            !*** determinant is non-zero, but the lines
+            !*** are actually coincident.  if this is the
+            !*** case, skip the rest.
+            !***
+
+            if (determ /= zero) then
+              s1 = (rhs1*mat4 - mat2*rhs2)/determ
+              s2 = (mat1*rhs2 - rhs1*mat3)/determ
+
+              if (.not. loutside) then
+                intrsct_x = begsegx + s1*mat1
+                intrsct_y = begsegy + s1*mat3
+              else 
+                intrsct_x = endx + s1*mat1
+                intrsct_y = endy + s1*mat3
+              endif
+
+              !***
+              !*** convert back to lat/lon coordinates
+              !***
+
+              intrsct_lon = rns*atan2(intrsct_y,intrsct_x)
+              if (intrsct_lon < zero) 
+     &          intrsct_lon = intrsct_lon + pi2
+
+              if (abs(intrsct_x) > 1.d-10) then
+                intrsct_lat = (pi4 - 
+     &            asin(rns*half*intrsct_x/cos(intrsct_lon)))*two
+              else if (abs(intrsct_y) > 1.d-10) then
+                intrsct_lat = (pi4 - 
+     &            asin(half*intrsct_y/sin(intrsct_lon)))*two
+              else
+                intrsct_lat = two*pi4
+              endif
+
+              !***
+              !*** add offset in transformed space for next pass.
+              !***
+
+              if (s1 - eps/determ < one) then
+                intrsct_x = intrsct_x - mat1*(eps/determ)
+                intrsct_y = intrsct_y - mat3*(eps/determ)
+              else
+                if (.not. loutside) then
+                  intrsct_x = endx
+                  intrsct_y = endy
+                  intrsct_lat = endlat
+                  intrsct_lon = endlon
+                else 
+                  intrsct_x = begsegx
+                  intrsct_y = begsegy
+                  intrsct_lat = begseg(1)
+                  intrsct_lon = begseg(2)
+                endif
+              endif
+
+              exit intrsct_loop
+            endif
+          endif
+        endif
+
+        !***
+        !*** no intersection this side, move on to next side
+        !***
+
+      end do intrsct_loop
+      call timer_stop(13)
+
+      deallocate(srch_corner_x, srch_corner_y)
+
+!-----------------------------------------------------------------------
+!
+!     if segment manages to cross over pole, shift the beginning 
+!     endpoint in order to avoid hitting pole directly
+!     (it is ok for endpoint to be pole point)
+!
+!-----------------------------------------------------------------------
+
+      if (abs(intrsct_x) < 1.e-10 .and. abs(intrsct_y) < 1.e-10 .and.
+     &    (endx /= zero .and. endy /=0)) then
+        if (avoid_pole_count > 2) then
+           avoid_pole_count = 0
+           avoid_pole_offset = 10.*avoid_pole_offset
+        endif
+
+        cross_product = begsegx*(endy-begsegy) - begsegy*(endx-begsegx)
+        intrsct_lat = begseg(1)
+        if (cross_product*intrsct_lat > zero) then
+          intrsct_lon = beglon    + avoid_pole_offset
+          begseg(2)   = begseg(2) + avoid_pole_offset
+        else
+          intrsct_lon = beglon    - avoid_pole_offset
+          begseg(2)   = begseg(2) - avoid_pole_offset
+        endif
+
+        avoid_pole_count = avoid_pole_count + 1
+        luse_last = .false.
+      else
+        avoid_pole_count = 0
+        avoid_pole_offset = tiny
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     if the segment crosses a pole threshold, reset the intersection
+!     to be the threshold latitude and do not reuse x,y intersect
+!     on next entry.  only check if did not cross threshold last
+!     time - sometimes the coordinate transformation can place a
+!     segment on the other side of the threshold again
+!
+!-----------------------------------------------------------------------
+
+      if (lthresh) then
+        if (intrsct_lat > north_thresh .or. intrsct_lat < south_thresh)
+     &    lthresh = .false.
+      else if (beglat > zero .and. intrsct_lat < north_thresh) then
+        mat4 = endlat - begseg(1)
+        mat3 = endlon - begseg(2)
+        if (mat3 >  pi) mat3 = mat3 - pi2
+        if (mat3 < -pi) mat3 = mat3 + pi2
+        intrsct_lat = north_thresh - tiny
+        s1 = (north_thresh - begseg(1))/mat4
+        intrsct_lon = begseg(2) + s1*mat3
+        luse_last = .false.
+        lthresh = .true.
+      else if (beglat < zero .and. intrsct_lat > south_thresh) then
+        mat4 = endlat - begseg(1)
+        mat3 = endlon - begseg(2)
+        if (mat3 >  pi) mat3 = mat3 - pi2
+        if (mat3 < -pi) mat3 = mat3 + pi2
+        intrsct_lat = south_thresh + tiny
+        s1 = (south_thresh - begseg(1))/mat4
+        intrsct_lon = begseg(2) + s1*mat3
+        luse_last = .false.
+        lthresh = .true.
+      endif
+
+      !***
+      !*** if reached end of segment, do not use x,y intersect 
+      !*** on next entry
+      !***
+
+      if (intrsct_lat == endlat .and. intrsct_lon == endlon) then
+        luse_last = .false.
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine pole_intersection
+
+!***********************************************************************
+
+      subroutine line_integral(weights, num_wts, 
+     &                       in_phi1, in_phi2, theta1, theta2,
+     &                       grid1_lon, grid2_lon)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the line integral of the flux function 
+!     that results in the interpolation weights.  the line is defined
+!     by the input lat/lon of the endpoints.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     intent(in):
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        num_wts  ! number of weights to compute
+
+      real (kind=dbl_kind), intent(in) :: 
+     &     in_phi1, in_phi2,     ! longitude endpoints for the segment
+     &     theta1, theta2,       ! latitude  endpoints for the segment
+     &     grid1_lon, ! reference coordinates for each
+     &     grid2_lon  ! grid (to ensure correct 0,2pi interv.
+
+!-----------------------------------------------------------------------
+!
+!     intent(out):
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), dimension(2*num_wts), intent(out) ::
+     &     weights   ! line integral contribution to weights
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind) :: dphi, sinth1, sinth2, costh1, costh2, fac,
+     &                        phi1, phi2, phidiff1, phidiff2
+      real (kind=dbl_kind) :: f1, f2, fint
+
+!-----------------------------------------------------------------------
+!
+!     weights for the general case based on a trapezoidal approx to
+!     the integrals.
+!
+!-----------------------------------------------------------------------
+
+      sinth1 = SIN(theta1)
+      sinth2 = SIN(theta2)
+      costh1 = COS(theta1)
+      costh2 = COS(theta2)
+
+      dphi = in_phi1 - in_phi2
+      if (dphi >  pi) then
+        dphi = dphi - pi2
+      else if (dphi < -pi) then
+        dphi = dphi + pi2
+      endif
+      dphi = half*dphi
+
+!-----------------------------------------------------------------------
+!
+!     the first weight is the area overlap integral. the second and
+!     fourth are second-order latitude gradient weights.
+!
+!-----------------------------------------------------------------------
+
+      weights(        1) = dphi*(sinth1 + sinth2)
+      weights(num_wts+1) = dphi*(sinth1 + sinth2)
+      weights(        2) = dphi*(costh1 + costh2 + (theta1*sinth1 +
+     &                                              theta2*sinth2))
+      weights(num_wts+2) = dphi*(costh1 + costh2 + (theta1*sinth1 +
+     &                                              theta2*sinth2))
+
+!-----------------------------------------------------------------------
+!
+!     the third and fifth weights are for the second-order phi gradient
+!     component.  must be careful of longitude range.
+!
+!-----------------------------------------------------------------------
+
+      f1 = half*(costh1*sinth1 + theta1)
+      f2 = half*(costh2*sinth2 + theta2)
+
+      phi1 = in_phi1 - grid1_lon
+      if (phi1 >  pi) then
+        phi1 = phi1 - pi2
+      else if (phi1 < -pi) then
+        phi1 = phi1 + pi2
+      endif
+
+      phi2 = in_phi2 - grid1_lon
+      if (phi2 >  pi) then
+        phi2 = phi2 - pi2
+      else if (phi2 < -pi) then
+        phi2 = phi2 + pi2
+      endif
+
+      if ((phi2-phi1) <  pi .and. (phi2-phi1) > -pi) then
+        weights(3) = dphi*(phi1*f1 + phi2*f2)
+      else
+        if (phi1 > zero) then
+          fac = pi
+        else
+          fac = -pi
+        endif
+        fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi)
+        weights(3) = half*phi1*(phi1-fac)*f1 -
+     &               half*phi2*(phi2+fac)*f2 +
+     &               half*fac*(phi1+phi2)*fint
+      endif
+
+      phi1 = in_phi1 - grid2_lon
+      if (phi1 >  pi) then
+        phi1 = phi1 - pi2
+      else if (phi1 < -pi) then
+        phi1 = phi1 + pi2
+      endif
+
+      phi2 = in_phi2 - grid2_lon
+      if (phi2 >  pi) then
+        phi2 = phi2 - pi2
+      else if (phi2 < -pi) then
+        phi2 = phi2 + pi2
+      endif
+
+      if ((phi2-phi1) <  pi .and. (phi2-phi1) > -pi) then
+        weights(num_wts+3) = dphi*(phi1*f1 + phi2*f2)
+      else
+        if (phi1 > zero) then
+          fac = pi
+        else
+          fac = -pi
+        endif
+        fint = f1 + (f2-f1)*(fac-phi1)/abs(dphi)
+        weights(num_wts+3) = half*phi1*(phi1-fac)*f1 -
+     &                       half*phi2*(phi2+fac)*f2 +
+     &                       half*fac*(phi1+phi2)*fint
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine line_integral
+
+!***********************************************************************
+
+      subroutine store_link_cnsrv(add1, add2, weights)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for this link in
+!     the appropriate address and weight arrays and resizes those
+!     arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        add1,  ! address on grid1
+     &        add2   ! address on grid2
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        weights ! array of remapping weights for this link
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: nlink, min_link, max_link ! link index
+
+      integer (kind=int_kind), dimension(:,:), allocatable, save ::
+     &        link_add1,  ! min,max link add to restrict search
+     &        link_add2   ! min,max link add to restrict search
+
+!-----------------------------------------------------------------------
+!
+!     if all weights are zero, do not bother storing the link
+!
+!-----------------------------------------------------------------------
+
+!SV      if (all(weights == zero)) return
+
+!-----------------------------------------------------------------------
+!
+!     restrict the range of links to search for existing links
+!
+!-----------------------------------------------------------------------
+
+      if (first_call) then
+        if (.not. first_conserv) then
+          deallocate(link_add1, link_add2)
+        endif
+        allocate(link_add1(2,grid1_size), link_add2(2,grid2_size))
+        link_add1 = 0
+        link_add2 = 0
+        first_call = .false.
+        min_link = 1
+        max_link = 0
+      else
+        min_link = min(link_add1(1,add1),link_add2(1,add2))
+        max_link = max(link_add1(2,add1),link_add2(2,add2))
+        if (min_link == 0) then
+          min_link = 1
+          max_link = 0
+        endif
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     if the link already exists, add the weight to the current weight
+!     arrays
+!
+!-----------------------------------------------------------------------
+
+      do nlink=min_link,max_link
+        if (add1 == grid1_add_map1(nlink)) then
+        if (add2 == grid2_add_map1(nlink)) then
+
+          wts_map1(:,nlink) = wts_map1(:,nlink) + weights(1:num_wts)
+!          if (num_maps == 2) then
+!            wts_map2(:,nlink) = wts_map2(:,nlink) + 
+!     &                                  weights(num_wts+1:2*num_wts)
+!          endif
+          return
+
+        endif
+        endif
+      end do
+
+!-----------------------------------------------------------------------
+!
+!     if the link does not yet exist, increment number of links and 
+!     check to see if remap arrays need to be increased to accomodate 
+!     the new link.  then store the link.
+!
+!-----------------------------------------------------------------------
+
+      num_links_map1  = num_links_map1 + 1
+      if (num_links_map1 > max_links_map1) 
+     &   call resize_remap_vars(1,resize_increment)
+
+      grid1_add_map1(num_links_map1) = add1
+      grid2_add_map1(num_links_map1) = add2
+      wts_map1    (:,num_links_map1) = weights(1:num_wts)
+
+!      if (num_maps > 1) then
+!        num_links_map2  = num_links_map2 + 1
+!        if (num_links_map2 > max_links_map2) 
+!     &     call resize_remap_vars(2,resize_increment)
+!
+!        grid1_add_map2(num_links_map2) = add1
+!        grid2_add_map2(num_links_map2) = add2
+!        wts_map2    (:,num_links_map2) = weights(num_wts+1:2*num_wts)
+!      endif
+
+      if (link_add1(1,add1) == 0) link_add1(1,add1) = num_links_map1
+      if (link_add2(1,add2) == 0) link_add2(1,add2) = num_links_map1
+      link_add1(2,add1) = num_links_map1
+      link_add2(2,add2) = num_links_map1
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_cnsrv
+
+!***********************************************************************
+
+      end module remap_conservative
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_distwgt.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_distwgt.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_distwgt.f	(revision 1677)
@@ -0,0 +1,527 @@
+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       - restrict types are written in capital letters
+C       - bug line 386: bin_lons(3,n) instead of bin_lons(2,n)
+C
+C     Modified by            V. Gayler,  M&D                  20.09.2001
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for performing an 
+!     interpolation using a distance-weighted average of n nearest
+!     neighbors.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_distwgt.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 remap_distance_weight 
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid info
+      use remap_vars    ! module containing remap info
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     module variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), dimension(:), allocatable, save ::
+     &     coslat, sinlat, ! cosine, sine of grid lats (for distance)
+     &     coslon, sinlon, ! cosine, sine of grid lons (for distance)
+     &     wgtstmp         ! an array to hold the link weight
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_distwgt (lextrapdone, num_neighbors)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the inverse-distance weights for a
+!     nearest-neighbor interpolation.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+
+      INTEGER (kind=int_kind) ::
+     &       num_neighbors     ! number of neighbours
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      logical (kind=log_kind), dimension(num_neighbors) ::
+     &     nbr_mask        ! mask at nearest neighbors
+
+      integer (kind=int_kind) :: n,
+     &     dst_add,        ! destination address
+     &     nmap            ! index of current map being computed
+
+      integer (kind=int_kind), dimension(num_neighbors) ::
+     &     nbr_add         ! source address at nearest neighbors
+
+      real (kind=dbl_kind), dimension(num_neighbors) ::
+     &     nbr_dist        ! angular distance four nearest neighbors
+
+      real (kind=dbl_kind) ::
+     &     coslat_dst,     ! cos(lat) of destination grid point
+     &     coslon_dst,     ! cos(lon) of destination grid point
+     &     sinlat_dst,     ! sin(lat) of destination grid point
+     &     sinlon_dst,     ! sin(lon) of destination grid point
+     &     dist_tot        ! sum of neighbor distances (for normalizing)
+
+      real (kind=dbl_kind) :: dl_test
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid1 to grid2
+!
+!-----------------------------------------------------------------------
+      dl_test = 0.0
+      nmap = 1
+
+      !***
+      !*** allocate wgtstmp to be consistent with store_link interface
+      !***
+
+      allocate (wgtstmp(num_wts))
+
+      !***
+      !*** compute cos, sin of lat/lon on source grid for distance
+      !*** calculations
+      !***
+
+      allocate (coslat(grid1_size), coslon(grid1_size),
+     &          sinlat(grid1_size), sinlon(grid1_size))
+
+      coslat = cos(grid1_center_lat)
+      coslon = cos(grid1_center_lon)
+      sinlat = sin(grid1_center_lat)
+      sinlon = sin(grid1_center_lon)
+
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop1: do dst_add = 1, grid2_size
+
+        if (.not. grid2_mask(dst_add)) cycle grid_loop1
+
+        coslat_dst = cos(grid2_center_lat(dst_add))
+        coslon_dst = cos(grid2_center_lon(dst_add))
+        sinlat_dst = sin(grid2_center_lat(dst_add))
+        sinlon_dst = sin(grid2_center_lon(dst_add))
+
+        !***
+        !*** find nearest grid points on source grid and
+        !*** distances to each point
+        !***
+
+        call grid_search_nbr(nbr_add, nbr_dist, 
+     &                       grid2_center_lat(dst_add),
+     &                       grid2_center_lon(dst_add),
+     &                       coslat_dst, coslon_dst, 
+     &                       sinlat_dst, sinlon_dst,
+     &                       bin_addr1, num_neighbors)
+
+        !***
+        !*** compute weights based on inverse distance
+        !*** if mask is false, eliminate those points
+        !***
+
+        dist_tot = zero
+        do n=1,num_neighbors
+          if ((grid1_mask(nbr_add(n))) .or. 
+     &        (.not. grid1_mask(nbr_add(n)) .and. lextrapdone)) then
+            nbr_dist(n) = one/(nbr_dist(n) + epsilon(dl_test))
+            nbr_dist(n) = one/nbr_dist(n)
+            dist_tot = dist_tot + nbr_dist(n)
+            nbr_mask(n) = .true.
+          else
+            nbr_mask(n) = .false.
+          endif
+        end do
+
+        !***
+        !*** normalize weights and store the link
+        !***
+        do n=1,num_neighbors
+          if (nbr_mask(n)) then
+            wgtstmp(1) = nbr_dist(n)/dist_tot
+            call store_link_nbr(nbr_add(n), dst_add, wgtstmp, nmap)
+            grid2_frac(dst_add) = one
+          endif
+        end do
+
+      end do grid_loop1
+
+      deallocate (coslat, coslon, sinlat, sinlon)
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid2 to grid1 if necessary
+!
+!-----------------------------------------------------------------------
+
+      if (num_maps > 1) then
+
+      nmap = 2
+
+      !***
+      !*** compute cos, sin of lat/lon on source grid for distance
+      !*** calculations
+      !***
+
+      allocate (coslat(grid2_size), coslon(grid2_size),
+     &          sinlat(grid2_size), sinlon(grid2_size))
+
+      coslat = cos(grid2_center_lat)
+      coslon = cos(grid2_center_lon)
+      sinlat = sin(grid2_center_lat)
+      sinlon = sin(grid2_center_lon)
+
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop2: do dst_add = 1, grid1_size
+
+        if (.not. grid1_mask(dst_add)) cycle grid_loop2
+
+        coslat_dst = cos(grid1_center_lat(dst_add))
+        coslon_dst = cos(grid1_center_lon(dst_add))
+        sinlat_dst = sin(grid1_center_lat(dst_add))
+        sinlon_dst = sin(grid1_center_lon(dst_add))
+
+        !***
+        !*** find four nearest grid points on source grid and
+        !*** distances to each point
+        !***
+
+        call grid_search_nbr(nbr_add, nbr_dist,
+     &                       grid1_center_lat(dst_add),
+     &                       grid1_center_lon(dst_add),
+     &                       coslat_dst, coslon_dst, 
+     &                       sinlat_dst, sinlon_dst,
+     &                       bin_addr2, num_neighbors)
+
+        !***
+        !*** compute weights based on inverse distance
+        !*** if mask is false, eliminate those points
+        !***
+
+        dist_tot = zero
+        do n=1,num_neighbors
+          if (grid2_mask(nbr_add(n))) then
+            nbr_dist(n) = one/(nbr_dist(n) + epsilon(dl_test))
+            dist_tot = dist_tot + nbr_dist(n)
+            nbr_mask(n) = .true.
+          else
+            nbr_mask(n) = .false.
+          endif
+        end do
+
+        !***
+        !*** normalize weights and store the link
+        !***
+
+        do n=1,num_neighbors
+          if (nbr_mask(n)) then
+            wgtstmp(1) = nbr_dist(n)/dist_tot
+            call store_link_nbr(dst_add, nbr_add(n), wgtstmp, nmap)
+            grid1_frac(dst_add) = one
+          endif
+        end do
+
+      end do grid_loop2
+
+      deallocate (coslat, coslon, sinlat, sinlon)
+
+      endif
+
+      deallocate(wgtstmp)
+
+!-----------------------------------------------------------------------
+
+      end subroutine remap_distwgt
+
+!***********************************************************************
+
+      subroutine grid_search_nbr(nbr_add, nbr_dist, plat, plon, 
+     &               coslat_dst, coslon_dst, sinlat_dst, sinlon_dst,
+     &               src_bin_add, num_neighbors)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the closest num_neighbor points to a search 
+!     point and computes a distance to each of the neighbors.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(:,:), intent(in) ::
+     &        src_bin_add ! search bins for restricting search
+
+      real (kind=dbl_kind), intent(in) ::
+     &        plat,         ! latitude  of the search point
+     &        plon,         ! longitude of the search point
+     &        coslat_dst,   ! cos(lat)  of the search point
+     &        coslon_dst,   ! cos(lon)  of the search point
+     &        sinlat_dst,   ! sin(lat)  of the search point
+     &        sinlon_dst    ! sin(lon)  of the search point
+
+      INTEGER (kind=int_kind) ::
+     &       num_neighbors     ! number of neighbours
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(num_neighbors), intent(out) ::
+     &        nbr_add  ! address of each of the closest points
+
+      real (kind=dbl_kind), dimension(num_neighbors), intent(out) ::
+     &        nbr_dist ! distance to each of the closest points
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, nmax, nadd, nchk, ! dummy indices
+     &        min_add, max_add, nm1, np1, i, j, ip1, im1, jp1, jm1
+
+      real (kind=dbl_kind) ::
+     &        distance      ! angular distance
+
+!-----------------------------------------------------------------------
+!
+!     loop over source grid and find nearest neighbors
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** restrict the search using search bins
+      !*** expand the bins to catch neighbors
+      !***
+
+      select case (restrict_type)
+      case('LATITUDE')
+
+        do n=1,num_srch_bins
+          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n)) then
+            min_add = src_bin_add(1,n)
+            max_add = src_bin_add(2,n)
+
+            nm1 = max(n-1,1)
+            np1 = min(n+1,num_srch_bins)
+
+            min_add = min(min_add,src_bin_add(1,nm1))
+            max_add = max(max_add,src_bin_add(2,nm1))
+            min_add = min(min_add,src_bin_add(1,np1))
+            max_add = max(max_add,src_bin_add(2,np1))
+          endif
+        end do
+
+      case('LATLON')
+
+        n = 0
+        nmax = nint(sqrt(real(num_srch_bins)))
+        do j=1,nmax
+        jp1 = min(j+1,nmax)
+        jm1 = max(j-1,1)
+        do i=1,nmax
+          ip1 = min(i+1,nmax)
+          im1 = max(i-1,1)
+
+          n = n+1
+          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and.
+     &        plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then
+            min_add = src_bin_add(1,n)
+            max_add = src_bin_add(2,n)
+
+            nm1 = (jm1-1)*nmax + im1
+            np1 = (jp1-1)*nmax + ip1
+            nm1 = max(nm1,1)
+            np1 = min(np1,num_srch_bins)
+
+            min_add = min(min_add,src_bin_add(1,nm1))
+            max_add = max(max_add,src_bin_add(2,nm1))
+            min_add = min(min_add,src_bin_add(1,np1))
+            max_add = max(max_add,src_bin_add(2,np1))
+          endif
+        end do
+        end do
+
+      end select
+
+      !***
+      !*** initialize distance and address arrays
+      !***
+
+      nbr_add = 0
+      nbr_dist = bignum
+
+      do nadd=min_add,max_add
+
+        !***
+        !*** find distance to this point
+        !***
+        distance = acos(sinlat_dst*sinlat(nadd) +
+     &                  coslat_dst*coslat(nadd)*
+     &                 (coslon_dst*coslon(nadd) +
+     &                  sinlon_dst*sinlon(nadd)) )
+
+        !***
+        !*** store the address and distance if this is one of the
+        !*** smallest four so far
+        !***
+
+        check_loop: do nchk=1,num_neighbors
+          if (distance .lt. nbr_dist(nchk)) then
+            do n=num_neighbors,nchk+1,-1
+              nbr_add(n) = nbr_add(n-1)
+              nbr_dist(n) = nbr_dist(n-1)
+            end do
+            nbr_add(nchk) = nadd
+            nbr_dist(nchk) = distance
+            exit check_loop
+          endif
+        end do check_loop
+
+      end do
+
+!-----------------------------------------------------------------------
+
+      end subroutine grid_search_nbr 
+
+!***********************************************************************
+
+      subroutine store_link_nbr(add1, add2, weights, nmap)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for this link in
+!     the appropriate address and weight arrays and resizes those
+!     arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        add1,  ! address on grid1
+     &        add2,  ! address on grid2
+     &        nmap   ! identifies which direction for mapping
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        weights ! array of remapping weights for this link
+
+!-----------------------------------------------------------------------
+!
+!     increment number of links and check to see if remap arrays need
+!     to be increased to accomodate the new link.  then store the
+!     link.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        num_links_map1  = num_links_map1 + 1
+
+        if (num_links_map1 > max_links_map1) 
+     &     call resize_remap_vars(1,resize_increment)
+
+        grid1_add_map1(num_links_map1) = add1
+        grid2_add_map1(num_links_map1) = add2
+        wts_map1    (:,num_links_map1) = weights
+
+      case(2)
+
+        num_links_map2  = num_links_map2 + 1
+
+        if (num_links_map2 > max_links_map2) 
+     &     call resize_remap_vars(2,resize_increment)
+
+        grid1_add_map2(num_links_map2) = add1
+        grid2_add_map2(num_links_map2) = add2
+        wts_map2    (:,num_links_map2) = weights
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_nbr
+
+!***********************************************************************
+
+      end module remap_distance_weight
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_gauswgt.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_gauswgt.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_gauswgt.f	(revision 1677)
@@ -0,0 +1,655 @@
+C****
+C                    ************************
+C                    *     OASIS MODULE     *
+C                    *     ------------     *
+C                    ************************
+C**** 
+C***********************************************************************
+C     This module belongs to the SCRIP library. It is a modified version
+C     of SCRIP 1.4 remap_ditswgt.f in order to weight a neighbour by
+C     exp[-1/2 * d^^2/sigma^^2] where d is the distance between the source
+C     and the target points and sigma^^2=VAR*dm^^2, where dm is the
+C     average distance between the source grid points and VAR is a value 
+C     given by the user.
+C
+C     Additional Modifications:
+C       - restrict types are written in capital letters
+C       - bug line 429: bin_lons(3,n) instead of bin_lons(2,n)
+C
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary routines for performing an 
+!     interpolation using a distance-weighted average of n nearest
+!     neighbors.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_gauswgt.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 remap_gaussian_weight
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common constants
+      use grids         ! module containing grid info
+      use remap_vars    ! module containing remap info
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     module variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), dimension(:), allocatable, save ::
+     &     coslat, sinlat, ! cosine, sine of grid lats (for distance)
+     &     coslon, sinlon, ! cosine, sine of grid lons (for distance)
+     &     wgtstmp         ! an array to hold the link weight
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine remap_gauswgt (lextrapdone, num_neighbors, rl_varmul)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the inverse-distance weights for a
+!     nearest-neighbor interpolation.
+!
+!-----------------------------------------------------------------------
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+      REAL (kind=real_kind) ::
+     $    rl_varmul             ! Gaussian variance
+
+      INTEGER (kind=int_kind) ::
+     &       num_neighbors     ! number of neighbours
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      logical (kind=log_kind), dimension(num_neighbors) ::
+     &     nbr_mask        ! mask at nearest neighbors
+
+      integer (kind=int_kind) :: n,
+     &     dst_add,        ! destination address
+     &     nmap            ! index of current map being computed
+
+      integer (kind=int_kind), dimension(num_neighbors) ::
+     &     nbr_add         ! source address at nearest neighbors
+
+      real (kind=dbl_kind), dimension(num_neighbors) ::
+     &     nbr_dist        ! angular distance four nearest neighbors
+
+      real (kind=dbl_kind) ::
+     &     coslat_dst,     ! cos(lat) of destination grid point
+     &     coslon_dst,     ! cos(lon) of destination grid point
+     &     sinlat_dst,     ! sin(lat) of destination grid point
+     &     sinlon_dst,     ! sin(lon) of destination grid point
+     &     dist_tot,       ! sum of neighbor distances (for normalizing)
+     &     dist_average    ! average distance between the source points
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid1 to grid2
+!
+!-----------------------------------------------------------------------
+
+      nmap = 1
+
+      !***
+      !*** allocate wgtstmp to be consistent with store_link interface
+      !***
+
+      allocate (wgtstmp(num_wts))
+
+      !***
+      !*** compute cos, sin of lat/lon on source grid for distance
+      !*** calculations
+      !***
+
+      allocate (coslat(grid1_size), coslon(grid1_size),
+     &          sinlat(grid1_size), sinlon(grid1_size))
+
+      coslat = cos(grid1_center_lat)
+      coslon = cos(grid1_center_lon)
+      sinlat = sin(grid1_center_lat)
+      sinlon = sin(grid1_center_lon)
+
+      !***
+      !*** compute the average of the distances between the source points
+      !*** 
+
+      call grid_dist_average(grid1_size,
+     &                       coslat, coslon,
+     &                       sinlat, sinlon,
+     &                       dist_average)
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop1: do dst_add = 1, grid2_size
+
+        if (.not. grid2_mask(dst_add)) cycle grid_loop1
+
+        coslat_dst = cos(grid2_center_lat(dst_add))
+        coslon_dst = cos(grid2_center_lon(dst_add))
+        sinlat_dst = sin(grid2_center_lat(dst_add))
+        sinlon_dst = sin(grid2_center_lon(dst_add))
+
+        !***
+        !*** find nearest grid points on source grid and
+        !*** distances to each point
+        !***
+
+        call grid_search_nbrg(nbr_add, nbr_dist, 
+     &                        grid2_center_lat(dst_add),
+     &                        grid2_center_lon(dst_add),
+     &                        coslat_dst, coslon_dst, 
+     &                        sinlat_dst, sinlon_dst,
+     &                        bin_addr1, 
+     &                        dist_average,  num_neighbors, rl_varmul)
+
+        !***
+        !*** compute weights based on inverse distance
+        !*** if mask is false, eliminate those points
+        !***
+
+        dist_tot = zero
+        do n=1,num_neighbors
+          if ((grid1_mask(nbr_add(n))) .or.
+     &        (.not. grid1_mask(nbr_add(n)) .and. lextrapdone)) THEN
+            nbr_dist(n) = one/nbr_dist(n)
+            dist_tot = dist_tot + nbr_dist(n)
+            nbr_mask(n) = .true.
+          else
+            nbr_mask(n) = .false.
+          endif
+        end do
+
+        !***
+        !*** normalize weights and store the link
+        !***
+
+        do n=1,num_neighbors
+          if (nbr_mask(n)) then
+            wgtstmp(1) = nbr_dist(n)/dist_tot
+            call store_link_nbr(nbr_add(n), dst_add, wgtstmp, nmap)
+            grid2_frac(dst_add) = one
+          endif
+        end do
+
+      end do grid_loop1
+
+      deallocate (coslat, coslon, sinlat, sinlon)
+
+!-----------------------------------------------------------------------
+!
+!     compute mappings from grid2 to grid1 if necessary
+!
+!-----------------------------------------------------------------------
+
+      if (num_maps > 1) then
+
+      nmap = 2
+
+      !***
+      !*** compute cos, sin of lat/lon on source grid for distance
+      !*** calculations
+      !***
+
+      allocate (coslat(grid2_size), coslon(grid2_size),
+     &          sinlat(grid2_size), sinlon(grid2_size))
+
+      coslat = cos(grid2_center_lat)
+      coslon = cos(grid2_center_lon)
+      sinlat = sin(grid2_center_lat)
+      sinlon = sin(grid2_center_lon)
+
+      !***
+      !*** compute the average of the distances between the source points
+      !*** 
+
+      call grid_dist_average(grid2_size,
+     &                       coslat, coslon,
+     &                       sinlat, sinlon,
+     &                       dist_average)
+
+      !***
+      !*** loop over destination grid 
+      !***
+
+      grid_loop2: do dst_add = 1, grid1_size
+
+        if (.not. grid1_mask(dst_add)) cycle grid_loop2
+
+        coslat_dst = cos(grid1_center_lat(dst_add))
+        coslon_dst = cos(grid1_center_lon(dst_add))
+        sinlat_dst = sin(grid1_center_lat(dst_add))
+        sinlon_dst = sin(grid1_center_lon(dst_add))
+
+        !***
+        !*** find four nearest grid points on source grid and
+        !*** distances to each point
+        !***
+
+        call grid_search_nbrg(nbr_add, nbr_dist,
+     &                        grid1_center_lat(dst_add),
+     &                        grid1_center_lon(dst_add),
+     &                        coslat_dst, coslon_dst, 
+     &                        sinlat_dst, sinlon_dst,
+     &                        bin_addr2, 
+     &                        dist_average, num_neighbors, rl_varmul)
+
+        !***
+        !*** compute weights based on inverse distance
+        !*** if mask is false, eliminate those points
+        !***
+
+        dist_tot = zero
+        do n=1,num_neighbors
+          if (grid2_mask(nbr_add(n))) then
+            nbr_dist(n) = one/nbr_dist(n)
+            dist_tot = dist_tot + nbr_dist(n)
+            nbr_mask(n) = .true.
+          else
+            nbr_mask(n) = .false.
+          endif
+        end do
+
+        !***
+        !*** normalize weights and store the link
+        !***
+
+        do n=1,num_neighbors
+          if (nbr_mask(n)) then
+            wgtstmp(1) = nbr_dist(n)/dist_tot
+            call store_link_nbr(dst_add, nbr_add(n), wgtstmp, nmap)
+            grid1_frac(dst_add) = one
+          endif
+        end do
+
+      end do grid_loop2
+
+      deallocate (coslat, coslon, sinlat, sinlon)
+
+      endif
+
+      deallocate(wgtstmp)
+
+!-----------------------------------------------------------------------
+
+      end subroutine remap_gauswgt
+
+!***********************************************************************
+
+      subroutine grid_search_nbrg(nbr_add, nbr_dist, plat, plon, 
+     &               coslat_dst, coslon_dst, sinlat_dst, sinlon_dst,
+     &               src_bin_add, dst_average,
+     $               num_neighbors, rl_varmul)
+
+!-----------------------------------------------------------------------
+!
+!     this routine finds the closest num_neighbor points to a search 
+!     point and computes a distance to each of the neighbors.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(:,:), intent(in) ::
+     &        src_bin_add ! search bins for restricting search
+
+      real (kind=dbl_kind), intent(in) ::
+     &        plat,         ! latitude  of the search point
+     &        plon,         ! longitude of the search point
+     &        coslat_dst,   ! cos(lat)  of the search point
+     &        coslon_dst,   ! cos(lon)  of the search point
+     &        sinlat_dst,   ! sin(lat)  of the search point
+     &        sinlon_dst,   ! sin(lon)  of the search point
+     &        dst_average   ! average distance between the source points
+
+      REAL (kind=real_kind), intent(in) ::
+     &        rl_varmul     ! Gaussian variance
+
+      INTEGER (kind=int_kind) ::
+     &       num_neighbors     ! number of neighbours
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), dimension(num_neighbors), intent(out) ::
+     &        nbr_add  ! address of each of the closest points
+
+      real (kind=dbl_kind), dimension(num_neighbors), intent(out) ::
+     &        nbr_dist ! distance to each of the closest points
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: n, nmax, nadd, nchk, ! dummy indices
+     &        min_add, max_add, nm1, np1, i, j, ip1, im1, jp1, jm1
+
+      real (kind=dbl_kind) ::
+     &        distance      ! angular distance
+
+      real (kind=dbl_kind) ::
+     &        variance      ! variance for the gaussian FUNCTION
+
+
+!-----------------------------------------------------------------------
+!
+!     loop over source grid and find nearest neighbors
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** restrict the search using search bins
+      !*** expand the bins to catch neighbors
+      !***
+
+      select case (restrict_type)
+      case('LATITUDE')
+
+        do n=1,num_srch_bins
+          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n)) then
+            min_add = src_bin_add(1,n)
+            max_add = src_bin_add(2,n)
+
+            nm1 = max(n-1,1)
+            np1 = min(n+1,num_srch_bins)
+
+            min_add = min(min_add,src_bin_add(1,nm1))
+            max_add = max(max_add,src_bin_add(2,nm1))
+            min_add = min(min_add,src_bin_add(1,np1))
+            max_add = max(max_add,src_bin_add(2,np1))
+          endif
+        end do
+
+      case('LATLON')
+
+        n = 0
+        nmax = nint(sqrt(real(num_srch_bins)))
+        do j=1,nmax
+        jp1 = min(j+1,nmax)
+        jm1 = max(j-1,1)
+        do i=1,nmax
+          ip1 = min(i+1,nmax)
+          im1 = max(i-1,1)
+
+          n = n+1
+          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and.
+     &        plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then
+            min_add = src_bin_add(1,n)
+            max_add = src_bin_add(2,n)
+
+            nm1 = (jm1-1)*nmax + im1
+            np1 = (jp1-1)*nmax + ip1
+            nm1 = max(nm1,1)
+            np1 = min(np1,num_srch_bins)
+
+            min_add = min(min_add,src_bin_add(1,nm1))
+            max_add = max(max_add,src_bin_add(2,nm1))
+            min_add = min(min_add,src_bin_add(1,np1))
+            max_add = max(max_add,src_bin_add(2,np1))
+          endif
+        end do
+        end do
+
+      end select
+
+      !***
+      !*** initialize distance and address arrays
+      !***
+
+      nbr_add = 0
+      nbr_dist = bignum
+      variance = rl_varmul*dst_average*dst_average
+      do nadd=min_add,max_add
+
+        !***
+        !*** find distance to this point
+        !***
+
+        distance = acos(sinlat_dst*sinlat(nadd) +
+     &                  coslat_dst*coslat(nadd)*
+     &                 (coslon_dst*coslon(nadd) +
+     &                  sinlon_dst*sinlon(nadd)) )
+        !distance = min(500., distance) !ts-sv
+        !distance = exp(.5*distance*distance/variance)
+        !***
+        !*** store the address and distance if this is one of the
+        !*** smallest four so far
+        !***
+
+        check_loop: do nchk=1,num_neighbors
+          if (distance .lt. nbr_dist(nchk)) THEN
+            do n=num_neighbors,nchk+1,-1
+              nbr_add(n) = nbr_add(n-1)
+              nbr_dist(n) = nbr_dist(n-1)
+            end do
+            nbr_add(nchk) = nadd
+            nbr_dist(nchk) = distance
+            exit check_loop
+          endif
+        end do check_loop
+
+      end do
+
+      exp_loop: do nchk=1,num_neighbors
+          nbr_dist(nchk) = 
+     &     exp(.5*nbr_dist(nchk)*nbr_dist(nchk)/variance)
+      end do exp_loop
+
+!-----------------------------------------------------------------------
+
+      end subroutine grid_search_nbrg 
+
+!***********************************************************************
+
+      subroutine store_link_nbr(add1, add2, weights, nmap)
+
+!-----------------------------------------------------------------------
+!
+!     this routine stores the address and weight for this link in
+!     the appropriate address and weight arrays and resizes those
+!     arrays if necessary.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        add1,  ! address on grid1
+     &        add2,  ! address on grid2
+     &        nmap   ! identifies which direction for mapping
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        weights ! array of remapping weights for this link
+
+!-----------------------------------------------------------------------
+!
+!     increment number of links and check to see if remap arrays need
+!     to be increased to accomodate the new link.  then store the
+!     link.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        num_links_map1  = num_links_map1 + 1
+
+        if (num_links_map1 > max_links_map1) 
+     &     call resize_remap_vars(1,resize_increment)
+
+        grid1_add_map1(num_links_map1) = add1
+        grid2_add_map1(num_links_map1) = add2
+        wts_map1    (:,num_links_map1) = weights
+
+      case(2)
+
+        num_links_map2  = num_links_map2 + 1
+
+        if (num_links_map2 > max_links_map2) 
+     &     call resize_remap_vars(2,resize_increment)
+
+        grid1_add_map2(num_links_map2) = add1
+        grid2_add_map2(num_links_map2) = add2
+        wts_map2    (:,num_links_map2) = weights
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine store_link_nbr
+
+!***********************************************************************
+
+      subroutine grid_dist_average(grid_size,
+     &                             coslat_grid, coslon_grid,
+     &                             sinlat_grid, sinlon_grid,
+     &                             dist_average)
+
+!-----------------------------------------------------------------------
+!
+!     this routine computes the average distance between the points of a
+!     grid.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     output variables
+!
+!-----------------------------------------------------------------------
+
+      real (kind=dbl_kind), intent(out) ::
+     &        dist_average ! distance to each of the closest points
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &        grid_size  
+
+      real (kind=dbl_kind), dimension(:), intent(in) ::
+     &        coslat_grid,   ! cos(lat)  of the grid points
+     &        coslon_grid,   ! cos(lon)  of the grid points
+     &        sinlat_grid,   ! sin(lat)  of the grid points
+     &        sinlon_grid    ! sin(lon)  of the grid points
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: i
+
+!-----------------------------------------------------------------------
+!
+!     compute the distance over the grid and average
+!
+!-----------------------------------------------------------------------
+
+      dist_average = 0.0
+      DO i = 1, grid_size
+        IF (i .eq. 1) THEN 
+            dist_average = dist_average +
+     &          acos(sinlat_grid(grid_size)*sinlat_grid(i) +
+     &          coslat_grid(grid_size)*coslat_grid(i)*
+     &          (coslon_grid(grid_size)*coslon_grid(i) +
+     &          sinlon_grid(grid_size)*sinlon_grid(i))) 
+            dist_average = dist_average +
+     &          acos(sinlat_grid(i)*sinlat_grid(i+1) +
+     &          coslat_grid(i)*coslat_grid(i+1)*
+     &          (coslon_grid(i)*coslon_grid(i+1) +
+     &          sinlon_grid(i)*sinlon_grid(i+1)))             
+        ELSE IF (i .eq. grid_size) THEN 
+            dist_average = dist_average +
+     &          acos(sinlat_grid(i-1)*sinlat_grid(i) +
+     &          coslat_grid(i-1)*coslat_grid(i)*
+     &          (coslon_grid(i-1)*coslon_grid(i) +
+     &          sinlon_grid(i-1)*sinlon_grid(i)))             
+            dist_average = dist_average +
+     &          acos(sinlat_grid(i)*sinlat_grid(1) +
+     &          coslat_grid(i)*coslat_grid(1)*
+     &          (coslon_grid(i)*coslon_grid(1) +
+     &          sinlon_grid(i)*sinlon_grid(1)))             
+        ELSE
+            dist_average = dist_average +
+     &          acos(sinlat_grid(i-1)*sinlat_grid(i) +
+     &          coslat_grid(i-1)*coslat_grid(i)*
+     &          (coslon_grid(i-1)*coslon_grid(i) +
+     &          sinlon_grid(i-1)*sinlon_grid(i)))             
+            dist_average = dist_average +
+     &          acos(sinlat_grid(i)*sinlat_grid(i+1) +
+     &          coslat_grid(i)*coslat_grid(i+1)*
+     &          (coslon_grid(i)*coslon_grid(i+1) +
+     &          sinlon_grid(i)*sinlon_grid(i+1)))             
+        END IF
+      END DO
+      dist_average = dist_average / (2*grid_size)
+
+      END subroutine grid_dist_average
+
+!***********************************************************************
+
+      end module remap_gaussian_weight
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_vars.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_vars.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_vars.f	(revision 1677)
@@ -0,0 +1,387 @@
+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       - introduction of logical flags to allow multiple calls of SCRIP
+C       - deallocation of arrays not needed any more
+C       - added CASE for GAUSWGT
+C
+C     Modified by            V. Gayler,  M&D                  20.09.2001
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     this module contains necessary variables for remapping between
+!     two grids.  also routines for resizing and initializing these
+!     variables.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_vars.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 remap_vars
+
+      use kinds_mod
+      use constants
+      use grids
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     module variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), parameter ::
+     &      norm_opt_none    = 1
+     &,     norm_opt_dstarea = 2
+     &,     norm_opt_frcarea = 3
+     &,     norm_opt_nonorm  = 4
+
+      integer (kind=int_kind), parameter ::
+     &      map_type_conserv  = 1
+     &,     map_type_bilinear = 2
+     &,     map_type_bicubic  = 3
+     &,     map_type_distwgt  = 4
+     &,     map_type_gauswgt  = 5
+
+      integer (kind=int_kind), save :: 
+     &      max_links_map1  ! current size of link arrays
+     &,     num_links_map1  ! actual number of links for remapping
+     &,     max_links_map2  ! current size of link arrays
+     &,     num_links_map2  ! actual number of links for remapping
+     &,     num_maps        ! num of remappings for this grid pair
+     &,     num_wts         ! num of weights used in remapping
+     &,     map_type        ! identifier for remapping method
+     &,     norm_opt        ! option for normalization (conserv only)
+     &,     resize_increment ! default amount to increase array size
+
+      integer (kind=int_kind), dimension(:), allocatable, save ::
+     &      grid1_add_map1, ! grid1 address for each link in mapping 1
+     &      grid2_add_map1, ! grid2 address for each link in mapping 1
+     &      grid1_add_map2, ! grid1 address for each link in mapping 2
+     &      grid2_add_map2  ! grid2 address for each link in mapping 2
+
+      real (kind=dbl_kind), dimension(:,:), allocatable, save ::
+     &      wts_map1, ! map weights for each link (num_wts,max_links)
+     &      wts_map2  ! map weights for each link (num_wts,max_links)
+
+      logical (kind=log_kind), save :: lfracnnei = .false.
+ 
+      logical (kind=log_kind), save :: first_conserv = .true. ! flag to 
+                                ! indicate, whether scrip is called from
+                                ! oasis for the first time
+      logical (kind=log_kind), save :: first_call = .true. ! flag used in
+                                ! remap_conserve (store_link_cnsrv)
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine init_remap_vars (id_scripvoi)
+
+!-----------------------------------------------------------------------
+!
+!     this routine initializes some variables and provides an initial
+!     allocation of arrays (fairly large so frequent resizing 
+!     unnecessary).
+!
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      INTEGER (kind=int_kind)::
+     &     id_scripvoi          ! number of neighbours for DISTWGT and GAUSWGT
+
+!-----------------------------------------------------------------------
+!
+!     determine the number of weights
+!
+!-----------------------------------------------------------------------
+
+      select case (map_type)
+      case(map_type_conserv)
+        num_wts = 3
+      case(map_type_bilinear)
+        num_wts = 1
+      case(map_type_bicubic)
+          IF (restrict_type == 'REDUCED') THEN
+              num_wts = 1
+          ELSE
+              num_wts = 4
+          ENDIF
+          PRINT *, 'num_wts=', num_wts
+      case(map_type_distwgt)
+        num_wts = 1
+      case(map_type_gauswgt)
+        num_wts = 1
+      end select
+
+!-----------------------------------------------------------------------
+!
+!     initialize num_links and set max_links to four times the largest 
+!     of the destination grid sizes initially (can be changed later).
+!     set a default resize increment to increase the size of link
+!     arrays if the number of links exceeds the initial size
+!   
+!-----------------------------------------------------------------------
+
+      num_links_map1 = 0
+      select case (map_type)
+      case(map_type_conserv)
+          max_links_map1 = 4*grid2_size
+      case(map_type_bilinear)
+          max_links_map1 = 4*grid2_size
+      case(map_type_bicubic)
+          IF (restrict_type == 'REDUCED') THEN
+              max_links_map1 = 16*grid2_size
+          ELSE
+              max_links_map1 = 4*grid2_size
+          ENDIF
+      case(map_type_distwgt)
+          max_links_map1 = id_scripvoi*grid2_size
+      case(map_type_gauswgt)
+          max_links_map1 = id_scripvoi*grid2_size
+      END select
+
+      if (num_maps > 1) then
+        num_links_map2 = 0
+        max_links_map1 = max(4*grid1_size,4*grid2_size)
+        max_links_map2 = max_links_map1
+      endif
+
+      resize_increment = 0.1*max(grid1_size,grid2_size)
+
+!-----------------------------------------------------------------------
+!
+!     allocate address and weight arrays for mapping 1
+!   
+!-----------------------------------------------------------------------
+
+      allocate (grid1_add_map1(max_links_map1),
+     &          grid2_add_map1(max_links_map1),
+     &          wts_map1(num_wts, max_links_map1))
+
+!-----------------------------------------------------------------------
+!
+!     allocate address and weight arrays for mapping 2 if necessary 
+!   
+!-----------------------------------------------------------------------
+
+      if (num_maps > 1) then
+        allocate (grid1_add_map2(max_links_map2),
+     &            grid2_add_map2(max_links_map2),
+     &            wts_map2(num_wts, max_links_map2))
+      endif
+!-----------------------------------------------------------------------
+!
+!     initialize flag for routine store_link_cnsrv
+!   
+!-----------------------------------------------------------------------
+      first_call = .true.
+
+!-----------------------------------------------------------------------
+
+      end subroutine init_remap_vars
+
+!***********************************************************************
+
+      subroutine resize_remap_vars(nmap, increment)
+
+!-----------------------------------------------------------------------
+!
+!     this routine resizes remapping arrays by increasing(decreasing)
+!     the max_links by increment
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::
+     &     nmap,      ! identifies which mapping array to resize
+     &     increment  ! the number of links to add(subtract) to arrays
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) ::
+     &   ierr,     ! error flag
+     &   mxlinks   ! size of link arrays
+
+      integer (kind=int_kind), dimension(:), allocatable ::
+     &   add1_tmp, ! temp array for resizing address arrays
+     &   add2_tmp  ! temp array for resizing address arrays
+
+      real (kind=dbl_kind), dimension(:,:), allocatable ::
+     &   wts_tmp   ! temp array for resizing weight arrays
+
+!-----------------------------------------------------------------------
+!
+!     resize map 1 arrays if required.
+!
+!-----------------------------------------------------------------------
+
+      select case (nmap)
+      case(1)
+
+        !***
+        !*** allocate temporaries to hold original values
+        !***
+
+        mxlinks = size(grid1_add_map1)
+        allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), 
+     &            wts_tmp(num_wts,mxlinks))
+
+        add1_tmp = grid1_add_map1
+        add2_tmp = grid2_add_map1
+        wts_tmp  = wts_map1
+        
+        !***
+        !*** deallocate originals and increment max_links then
+        !*** reallocate arrays at new size
+        !***
+
+        deallocate (grid1_add_map1, grid2_add_map1, wts_map1)
+        max_links_map1 = mxlinks + increment
+        allocate (grid1_add_map1(max_links_map1),
+     &            grid2_add_map1(max_links_map1),
+     &            wts_map1(num_wts,max_links_map1))
+
+        !***
+        !*** restore original values from temp arrays and
+        !*** deallocate temps
+        !***
+
+        mxlinks = min(mxlinks, max_links_map1)
+        grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks)
+        grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks)
+        wts_map1    (:,1:mxlinks) = wts_tmp(:,1:mxlinks)
+        deallocate(add1_tmp, add2_tmp, wts_tmp)
+
+!-----------------------------------------------------------------------
+!
+!     resize map 2 arrays if required.
+!
+!-----------------------------------------------------------------------
+
+      case(2)
+
+        !***
+        !*** allocate temporaries to hold original values
+        !***
+
+        mxlinks = size(grid1_add_map2)
+        allocate (add1_tmp(mxlinks), add2_tmp(mxlinks), 
+     &            wts_tmp(num_wts,mxlinks),stat=ierr)
+        if (ierr .ne. 0) then
+          print *,'error allocating temps in resize: ',ierr
+          stop
+        endif
+
+        add1_tmp = grid1_add_map2
+        add2_tmp = grid2_add_map2
+        wts_tmp  = wts_map2
+        
+        !***
+        !*** deallocate originals and increment max_links then
+        !*** reallocate arrays at new size
+        !***
+
+        deallocate (grid1_add_map2, grid2_add_map2, wts_map2)
+        max_links_map2 = mxlinks + increment
+        allocate (grid1_add_map2(max_links_map2),
+     &            grid2_add_map2(max_links_map2),
+     &            wts_map2(num_wts,max_links_map2),stat=ierr)
+        if (ierr .ne. 0) then
+          print *,'error allocating new arrays in resize: ',ierr
+          stop
+        endif
+
+
+        !***
+        !*** restore original values from temp arrays and
+        !*** deallocate temps
+        !***
+
+        mxlinks = min(mxlinks, max_links_map2)
+        grid1_add_map2(1:mxlinks) = add1_tmp (1:mxlinks)
+        grid2_add_map2(1:mxlinks) = add2_tmp (1:mxlinks)
+        wts_map2    (:,1:mxlinks) = wts_tmp(:,1:mxlinks)
+        deallocate(add1_tmp, add2_tmp, wts_tmp)
+
+      end select
+
+!-----------------------------------------------------------------------
+
+      end subroutine resize_remap_vars
+!----------------------------------------------------------------------- 
+!----------------------------------------------------------------------- 
+      subroutine free_remap_vars
+!-----------------------------------------------------------------------
+!
+!     subroutine to deallocate allocated arrays
+!
+!----------------------------------------------------------------------- 
+
+      deallocate (grid1_add_map1, grid2_add_map1, wts_map1)
+
+      if (num_maps > 1) then
+        deallocate (grid1_add_map2, grid2_add_map2, wts_map2)
+      endif
+      if (map_type == map_type_conserv) then
+        first_call = .true.
+        first_conserv = .false.
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine free_remap_vars
+
+!***********************************************************************
+
+      end module remap_vars
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/remap_write.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/remap_write.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/remap_write.f	(revision 1677)
@@ -0,0 +1,1515 @@
+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       - Added CASE for GAUSWGT
+C
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module contains routines for writing the remapping data to 
+!     a file.  Before writing the data for each mapping, the links are 
+!     sorted by destination grid address.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: remap_write.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 remap_write
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common scalar constants
+      use grids         ! module containing grid information
+      use remap_vars    ! module containing remap information
+      use netcdf_mod    ! module with netCDF stuff
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     module variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len), private :: 
+     &   map_method       ! character string for map_type
+     &,  normalize_opt    ! character string for normalization option
+     &,  history          ! character string for history information
+     &,  convention       ! character string for output convention
+
+      character(8), private :: 
+     &   cdate            ! character date string
+
+      integer (kind=int_kind), dimension(:), allocatable, private ::
+     &   src_mask_int     ! integer masks to determine
+     &,  dst_mask_int     ! cells that participate in map
+
+!-----------------------------------------------------------------------
+!
+!     various netCDF identifiers used by output routines
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), private ::
+     &   ncstat               ! error flag for netCDF calls 
+     &,  nc_file_id           ! id for netCDF file
+     &,  nc_srcgrdsize_id     ! id for source grid size
+     &,  nc_dstgrdsize_id     ! id for destination grid size
+     &,  nc_srcgrdcorn_id     ! id for number of source grid corners
+     &,  nc_dstgrdcorn_id     ! id for number of dest grid corners
+     &,  nc_srcgrdrank_id     ! id for source grid rank
+     &,  nc_dstgrdrank_id     ! id for dest grid rank
+     &,  nc_numlinks_id       ! id for number of links in mapping
+     &,  nc_numwgts_id        ! id for number of weights for mapping
+     &,  nc_srcgrddims_id     ! id for source grid dimensions
+     &,  nc_dstgrddims_id     ! id for dest grid dimensions
+     &,  nc_srcgrdcntrlat_id  ! id for source grid center latitude
+     &,  nc_dstgrdcntrlat_id  ! id for dest grid center latitude
+     &,  nc_srcgrdcntrlon_id  ! id for source grid center longitude
+     &,  nc_dstgrdcntrlon_id  ! id for dest grid center longitude
+     &,  nc_srcgrdimask_id    ! id for source grid mask
+     &,  nc_dstgrdimask_id    ! id for dest grid mask
+     &,  nc_srcgrdcrnrlat_id  ! id for latitude of source grid corners
+     &,  nc_srcgrdcrnrlon_id  ! id for longitude of source grid corners
+     &,  nc_dstgrdcrnrlat_id  ! id for latitude of dest grid corners
+     &,  nc_dstgrdcrnrlon_id  ! id for longitude of dest grid corners
+     &,  nc_srcgrdarea_id     ! id for area of source grid cells
+     &,  nc_dstgrdarea_id     ! id for area of dest grid cells
+     &,  nc_srcgrdfrac_id     ! id for area fraction on source grid
+     &,  nc_dstgrdfrac_id     ! id for area fraction on dest grid
+     &,  nc_srcadd_id         ! id for map source address
+     &,  nc_dstadd_id         ! id for map destination address
+     &,  nc_rmpmatrix_id      ! id for remapping matrix
+
+      integer (kind=int_kind), dimension(2), private ::
+     &   nc_dims2_id  ! netCDF ids for 2d array dims
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine write_remap(map1_name, map2_name, 
+     &                       interp_file1, interp_file2, output_opt)
+
+!-----------------------------------------------------------------------
+!
+!     calls correct output routine based on output format choice
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len), intent(in) ::
+     &            map1_name,    ! name for mapping grid1 to grid2
+     &            map2_name,    ! name for mapping grid2 to grid1
+     &            interp_file1, ! filename for map1 remap data
+     &            interp_file2, ! filename for map2 remap data
+     &            output_opt    ! option for output conventions
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!     define some common variables to be used in all routines
+!
+!-----------------------------------------------------------------------
+      select case(norm_opt)
+      case (norm_opt_none)
+        normalize_opt = 'none'
+      case (norm_opt_frcarea)
+        normalize_opt = 'fracarea'
+      case (norm_opt_dstarea)
+        normalize_opt = 'destarea'
+      case (norm_opt_nonorm)
+        normalize_opt = 'no norm'
+      end select
+      select case(map_type)
+      case(map_type_conserv)
+        map_method = 'Conservative remapping'
+      case(map_type_bilinear)
+        map_method = 'Bilinear remapping'
+      case(map_type_distwgt)
+        map_method = 'Distance weighted avg of nearest neighbors'
+      case(map_type_gauswgt)
+        map_method = 'Gaussian weighted avg of nearest neighbors'
+      case(map_type_bicubic)
+        map_method = 'Bicubic remapping'
+      case default
+        stop 'Invalid Map Type'
+      end select
+
+      call date_and_time(date=cdate)
+      write (history,1000) cdate(5:6),cdate(7:8),cdate(1:4)
+ 1000 format('Created: ',a2,'-',a2,'-',a4)
+
+!-----------------------------------------------------------------------
+!
+!     call appropriate output routine
+!
+!-----------------------------------------------------------------------
+
+      select case(output_opt)
+      case ('scrip')
+        call write_remap_scrip(map1_name, interp_file1, 1)
+      case ('ncar-csm')
+        call write_remap_csm  (map1_name, interp_file1, 1)
+      case default
+        stop 'unknown output file convention'
+      end select
+
+!-----------------------------------------------------------------------
+!
+!     call appropriate output routine for second mapping if required
+!
+!-----------------------------------------------------------------------
+
+      if (num_maps > 1) then
+        select case(output_opt)
+        case ('scrip')
+          call write_remap_scrip(map2_name, interp_file2, 2)
+        case ('ncar-csm')
+          call write_remap_csm  (map2_name, interp_file2, 2)
+        case default
+          stop 'unknown output file convention'
+        end select
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine write_remap
+
+!***********************************************************************
+
+      subroutine write_remap_scrip(map_name, interp_file, direction)
+
+!-----------------------------------------------------------------------
+!
+!     writes remap data to a netCDF file using SCRIP conventions
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len), intent(in) ::
+     &            map_name     ! name for mapping 
+     &,           interp_file  ! filename for remap data
+
+      integer (kind=int_kind), intent(in) ::
+     &  direction              ! direction of map (1=grid1 to grid2
+                               !                   2=grid2 to grid1)
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len) ::
+     &  grid1_ctmp        ! character temp for grid1 names
+     &, grid2_ctmp        ! character temp for grid2 names
+
+      integer (kind=int_kind) ::
+     &  itmp1             ! integer temp
+     &, itmp2             ! integer temp
+     &, itmp3             ! integer temp
+     &, itmp4             ! integer temp
+
+!-----------------------------------------------------------------------
+!
+!     create netCDF file for mapping and define some global attributes
+!
+!-----------------------------------------------------------------------
+      ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** map name
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title',
+     &                          len_trim(map_name), map_name)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** normalization option
+      !***
+      ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization',
+     &                         len_trim(normalize_opt), normalize_opt)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** map method
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method',
+     &                          len_trim(map_method), map_method)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** history
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history',
+     &                          len_trim(history), history)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** file convention
+      !***
+      convention = 'SCRIP'
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions',
+     &                          len_trim(convention), convention)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** source and destination grid names
+      !***
+
+      if (direction == 1) then
+        grid1_ctmp = 'source_grid'
+        grid2_ctmp = 'dest_grid'
+      else
+        grid1_ctmp = 'dest_grid'
+        grid2_ctmp = 'source_grid'
+      endif
+
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp),
+     &                          len_trim(grid1_name), grid1_name)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp),
+     &                          len_trim(grid2_name), grid2_name)
+      call netcdf_error_handler(ncstat)
+
+!-----------------------------------------------------------------------
+!
+!     prepare netCDF dimension info
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** define grid size dimensions
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_size
+        itmp2 = grid2_size
+      else
+        itmp1 = grid2_size
+        itmp2 = grid1_size
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'src_grid_size', itmp1, 
+     &                     nc_srcgrdsize_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'dst_grid_size', itmp2, 
+     &                     nc_dstgrdsize_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid corner dimension
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_corners
+        itmp2 = grid2_corners
+      else
+        itmp1 = grid2_corners
+        itmp2 = grid1_corners
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'src_grid_corners', 
+     &                     itmp1, nc_srcgrdcorn_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'dst_grid_corners', 
+     &                     itmp2, nc_dstgrdcorn_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define grid rank dimension
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_rank
+        itmp2 = grid2_rank
+      else
+        itmp1 = grid2_rank
+        itmp2 = grid1_rank
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', 
+     &                     itmp1, nc_srcgrdrank_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', 
+     &                     itmp2, nc_dstgrdrank_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define map size dimensions
+      !***
+
+      if (direction == 1) then
+        itmp1 = num_links_map1
+      else
+        itmp1 = num_links_map2
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'num_links', 
+     &                     itmp1, nc_numlinks_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_dim (nc_file_id, 'num_wgts', 
+     &                     num_wts, nc_numwgts_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define grid dimensions
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT,
+     &                     1, nc_srcgrdrank_id, nc_srcgrddims_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT,
+     &                     1, nc_dstgrdrank_id, nc_dstgrddims_id)
+      call netcdf_error_handler(ncstat)
+!-----------------------------------------------------------------------
+!
+!     define all arrays for netCDF descriptors
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** define grid center latitude array
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_center_lat', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdcntrlat_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lat', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdcntrlat_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define grid center longitude array
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_center_lon', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdcntrlon_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_center_lon', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdcntrlon_id)
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define grid corner lat/lon arrays
+      !***
+
+      nc_dims2_id(1) = nc_srcgrdcorn_id
+      nc_dims2_id(2) = nc_srcgrdsize_id
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lat', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_srcgrdcrnrlat_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'src_grid_corner_lon', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_srcgrdcrnrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      nc_dims2_id(1) = nc_dstgrdcorn_id
+      nc_dims2_id(2) = nc_dstgrdsize_id
+
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lat', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_dstgrdcrnrlat_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_corner_lon', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_dstgrdcrnrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define units for all coordinate arrays
+      !***
+
+      if (direction == 1) then
+        grid1_ctmp = grid1_units
+        grid2_ctmp = grid2_units
+      else
+        grid1_ctmp = grid2_units
+        grid2_ctmp = grid1_units
+      endif
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid mask
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_imask', NF_INT,
+     &                     1, nc_srcgrdsize_id, nc_srcgrdimask_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_imask', NF_INT,
+     &                     1, nc_dstgrdsize_id, nc_dstgrdimask_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define grid area arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_area', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdarea_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, 
+     &                          'units', 14, 'square radians')
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_area', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdarea_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, 
+     &                          'units', 14, 'square radians')
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid fraction arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_frac', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdfrac_id)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_frac', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdfrac_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+      !***
+      !*** define mapping arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_address', 
+     &                     NF_INT, 1, nc_numlinks_id, 
+     &                     nc_srcadd_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'dst_address', 
+     &                     NF_INT, 1, nc_numlinks_id, 
+     &                     nc_dstadd_id)
+      call netcdf_error_handler(ncstat)
+
+      nc_dims2_id(1) = nc_numwgts_id
+      nc_dims2_id(2) = nc_numlinks_id
+
+      ncstat = nf_def_var (nc_file_id, 'remap_matrix', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_rmpmatrix_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** end definition stage
+      !***
+
+      ncstat = nf_enddef(nc_file_id)
+      call netcdf_error_handler(ncstat)
+!-----------------------------------------------------------------------
+!
+!     compute integer masks
+!
+!-----------------------------------------------------------------------
+
+      if (direction == 1) then
+        allocate (src_mask_int(grid1_size),
+     &            dst_mask_int(grid2_size))
+
+        where (grid2_mask)
+          dst_mask_int = 1
+        elsewhere
+          dst_mask_int = 0
+        endwhere
+
+        where (grid1_mask)
+          src_mask_int = 1
+        elsewhere
+          src_mask_int = 0
+        endwhere
+      else
+        allocate (src_mask_int(grid2_size),
+     &            dst_mask_int(grid1_size))
+
+        where (grid1_mask)
+          dst_mask_int = 1
+        elsewhere
+          dst_mask_int = 0
+        endwhere
+
+        where (grid2_mask)
+          src_mask_int = 1
+        elsewhere
+          src_mask_int = 0
+        endwhere
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     change units of lat/lon coordinates if input units different
+!     from radians
+!
+!-----------------------------------------------------------------------
+
+      if (grid1_units(1:7) == 'degrees' .and. direction == 1) then
+        grid1_center_lat = grid1_center_lat/deg2rad
+        grid1_center_lon = grid1_center_lon/deg2rad
+        grid1_corner_lat = grid1_corner_lat/deg2rad
+        grid1_corner_lon = grid1_corner_lon/deg2rad
+      endif
+
+      if (grid2_units(1:7) == 'degrees' .and. direction == 1) then
+        grid2_center_lat = grid2_center_lat/deg2rad
+        grid2_center_lon = grid2_center_lon/deg2rad
+        grid2_corner_lat = grid2_corner_lat/deg2rad
+        grid2_corner_lon = grid2_corner_lon/deg2rad
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     write mapping data
+!
+!-----------------------------------------------------------------------
+
+      if (direction == 1) then
+        itmp1 = nc_srcgrddims_id
+        itmp2 = nc_dstgrddims_id
+      else
+        itmp2 = nc_srcgrddims_id
+        itmp1 = nc_dstgrddims_id
+      endif
+
+      ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, 
+     &                        src_mask_int)
+      call netcdf_error_handler(ncstat)
+      ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id,
+     &                        dst_mask_int)
+      call netcdf_error_handler(ncstat)
+
+      deallocate(src_mask_int, dst_mask_int)
+
+      if (direction == 1) then
+        itmp1 = nc_srcgrdcntrlat_id
+        itmp2 = nc_srcgrdcntrlon_id
+        itmp3 = nc_srcgrdcrnrlat_id
+        itmp4 = nc_srcgrdcrnrlon_id
+      else
+        itmp1 = nc_dstgrdcntrlat_id
+        itmp2 = nc_dstgrdcntrlon_id
+        itmp3 = nc_dstgrdcrnrlat_id
+        itmp4 = nc_dstgrdcrnrlon_id
+      endif
+
+      ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon)
+      call netcdf_error_handler(ncstat)
+      if (.not. luse_grid_centers) then
+          ncstat = nf_put_var_double(nc_file_id, itmp3, 
+     $        grid1_corner_lat)
+          call netcdf_error_handler(ncstat)
+
+          ncstat = nf_put_var_double(nc_file_id, itmp4, 
+     $        grid1_corner_lon)
+          call netcdf_error_handler(ncstat)
+      endif
+
+      if (direction == 1) then
+        itmp1 = nc_dstgrdcntrlat_id
+        itmp2 = nc_dstgrdcntrlon_id
+        itmp3 = nc_dstgrdcrnrlat_id
+        itmp4 = nc_dstgrdcrnrlon_id
+      else
+        itmp1 = nc_srcgrdcntrlat_id
+        itmp2 = nc_srcgrdcntrlon_id
+        itmp3 = nc_srcgrdcrnrlat_id
+        itmp4 = nc_srcgrdcrnrlon_id
+      endif
+
+      ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon)
+      call netcdf_error_handler(ncstat)
+
+      if (.not. luse_grid_centers) then
+          ncstat = nf_put_var_double(nc_file_id, itmp3, 
+     $        grid2_corner_lat)
+          call netcdf_error_handler(ncstat)
+
+          ncstat = nf_put_var_double(nc_file_id, itmp4, 
+     $        grid2_corner_lon)
+          call netcdf_error_handler(ncstat)
+      endif
+      if (direction == 1) then
+        itmp1 = nc_srcgrdarea_id
+        itmp2 = nc_srcgrdfrac_id
+        itmp3 = nc_dstgrdarea_id
+        itmp4 = nc_dstgrdfrac_id
+      else
+        itmp1 = nc_dstgrdarea_id
+        itmp2 = nc_dstgrdfrac_id
+        itmp3 = nc_srcgrdarea_id
+        itmp4 = nc_srcgrdfrac_id
+      endif
+
+      if (luse_grid1_area) then
+        ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in)
+      else
+        ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area)
+      endif
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac)
+      call netcdf_error_handler(ncstat)
+
+      if (luse_grid2_area) then
+        ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area_in)
+      else
+        ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area)
+      endif
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac)
+      call netcdf_error_handler(ncstat)
+      if (direction == 1) then
+        ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, 
+     &                          grid1_add_map1)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, 
+     &                          grid2_add_map1)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                             wts_map1)
+        call netcdf_error_handler(ncstat)
+      else
+        ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, 
+     &                          grid2_add_map2)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, 
+     &                          grid1_add_map2)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                             wts_map2)
+        call netcdf_error_handler(ncstat)
+      endif
+
+      ncstat = nf_close(nc_file_id)
+      call netcdf_error_handler(ncstat)
+!-----------------------------------------------------------------------
+
+      end subroutine write_remap_scrip
+
+!***********************************************************************
+
+      subroutine write_remap_csm(map_name, interp_file, direction)
+
+!-----------------------------------------------------------------------
+!
+!     writes remap data to a netCDF file using NCAR-CSM conventions
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len), intent(in) ::
+     &            map_name     ! name for mapping 
+     &,           interp_file  ! filename for remap data
+
+      integer (kind=int_kind), intent(in) ::
+     &  direction              ! direction of map (1=grid1 to grid2
+                               !                   2=grid2 to grid1)
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      character(char_len) ::
+     &  grid1_ctmp        ! character temp for grid1 names
+     &, grid2_ctmp        ! character temp for grid2 names
+
+      integer (kind=int_kind) ::
+     &  itmp1             ! integer temp
+     &, itmp2             ! integer temp
+     &, itmp3             ! integer temp
+     &, itmp4             ! integer temp
+     &, nc_numwgts1_id    ! extra netCDF id for additional weights
+     &, nc_src_isize_id   ! extra netCDF id for ni_a
+     &, nc_src_jsize_id   ! extra netCDF id for nj_a
+     &, nc_dst_isize_id   ! extra netCDF id for ni_b
+     &, nc_dst_jsize_id   ! extra netCDF id for nj_b
+     &, nc_rmpmatrix2_id  ! extra netCDF id for high-order remap matrix
+
+      real (kind=dbl_kind), dimension(:),allocatable ::
+     &  wts1              ! CSM wants single array for 1st-order wts
+
+      real (kind=dbl_kind), dimension(:,:),allocatable ::
+     &  wts2              ! write remaining weights in different array
+
+!-----------------------------------------------------------------------
+!
+!     create netCDF file for mapping and define some global attributes
+!
+!-----------------------------------------------------------------------
+
+      ncstat = nf_create (interp_file, NF_CLOBBER, nc_file_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** map name
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'title',
+     &                          len_trim(map_name), map_name)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** normalization option
+      !***
+      ncstat = nf_put_att_text(nc_file_id, NF_GLOBAL, 'normalization',
+     &                         len_trim(normalize_opt), normalize_opt)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** map method
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'map_method',
+     &                          len_trim(map_method), map_method)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** history
+      !***
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'history',
+     &                          len_trim(history), history)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** file convention
+      !***
+      convention = 'NCAR-CSM'
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, 'conventions',
+     &                          len_trim(convention), convention)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** source and destination grid names
+      !***
+
+      if (direction == 1) then
+        grid1_ctmp = 'domain_a'
+        grid2_ctmp = 'domain_b'
+      else
+        grid1_ctmp = 'domain_b'
+        grid2_ctmp = 'domain_a'
+      endif
+
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid1_ctmp),
+     &                          len_trim(grid1_name), grid1_name)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, NF_GLOBAL, trim(grid2_ctmp),
+     &                          len_trim(grid2_name), grid2_name)
+      call netcdf_error_handler(ncstat)
+
+!-----------------------------------------------------------------------
+!
+!     prepare netCDF dimension info
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** define grid size dimensions
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_size
+        itmp2 = grid2_size
+      else
+        itmp1 = grid2_size
+        itmp2 = grid1_size
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'n_a', itmp1, nc_srcgrdsize_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'n_b', itmp2, nc_dstgrdsize_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid corner dimension
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_corners
+        itmp2 = grid2_corners
+      else
+        itmp1 = grid2_corners
+        itmp2 = grid1_corners
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'nv_a', itmp1, nc_srcgrdcorn_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'nv_b', itmp2, nc_dstgrdcorn_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid rank dimension
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_rank
+        itmp2 = grid2_rank
+      else
+        itmp1 = grid2_rank
+        itmp2 = grid1_rank
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'src_grid_rank', 
+     &                     itmp1, nc_srcgrdrank_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'dst_grid_rank', 
+     &                     itmp2, nc_dstgrdrank_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define first two dims as if 2-d cartesian domain
+      !***
+
+      if (direction == 1) then
+        itmp1 = grid1_dims(1)
+        if (grid1_rank > 1) then
+          itmp2 = grid1_dims(2)
+        else
+          itmp2 = 0
+        endif
+        itmp3 = grid2_dims(1)
+        if (grid2_rank > 1) then
+          itmp4 = grid2_dims(2)
+        else
+          itmp4 = 0
+        endif
+      else
+        itmp1 = grid2_dims(1)
+        if (grid2_rank > 1) then
+          itmp2 = grid2_dims(2)
+        else
+          itmp2 = 0
+        endif
+        itmp3 = grid1_dims(1)
+        if (grid1_rank > 1) then
+          itmp4 = grid1_dims(2)
+        else
+          itmp4 = 0
+        endif
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'ni_a', itmp1, nc_src_isize_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'nj_a', itmp2, nc_src_jsize_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'ni_b', itmp3, nc_dst_isize_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'nj_b', itmp4, nc_dst_jsize_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define map size dimensions
+      !***
+
+      if (direction == 1) then
+        itmp1 = num_links_map1
+      else
+        itmp1 = num_links_map2
+      endif
+
+      ncstat = nf_def_dim (nc_file_id, 'n_s', itmp1, nc_numlinks_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_dim (nc_file_id, 'num_wgts', 
+     &                     num_wts, nc_numwgts_id)
+      call netcdf_error_handler(ncstat)
+
+      if (num_wts > 1) then
+        ncstat = nf_def_dim (nc_file_id, 'num_wgts1', 
+     &                       num_wts-1, nc_numwgts1_id)
+        call netcdf_error_handler(ncstat)
+      endif
+
+      !***
+      !*** define grid dimensions
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'src_grid_dims', NF_INT,
+     &                     1, nc_srcgrdrank_id, nc_srcgrddims_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'dst_grid_dims', NF_INT,
+     &                     1, nc_dstgrdrank_id, nc_dstgrddims_id)
+      call netcdf_error_handler(ncstat)
+
+!-----------------------------------------------------------------------
+!
+!     define all arrays for netCDF descriptors
+!
+!-----------------------------------------------------------------------
+
+      !***
+      !*** define grid center latitude array
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'yc_a',
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdcntrlat_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'yc_b', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdcntrlat_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid center longitude array
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'xc_a', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdcntrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'xc_b', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdcntrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid corner lat/lon arrays
+      !***
+
+      nc_dims2_id(1) = nc_srcgrdcorn_id
+      nc_dims2_id(2) = nc_srcgrdsize_id
+
+      ncstat = nf_def_var (nc_file_id, 'yv_a', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_srcgrdcrnrlat_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'xv_a', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_srcgrdcrnrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      nc_dims2_id(1) = nc_dstgrdcorn_id
+      nc_dims2_id(2) = nc_dstgrdsize_id
+
+      ncstat = nf_def_var (nc_file_id, 'yv_b', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_dstgrdcrnrlat_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'xv_b', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_dstgrdcrnrlon_id)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** CSM wants all in degrees
+      !***
+
+      grid1_units = 'degrees'
+      grid2_units = 'degrees'
+
+      if (direction == 1) then
+        grid1_ctmp = grid1_units
+        grid2_ctmp = grid2_units
+      else
+        grid1_ctmp = grid2_units
+        grid2_ctmp = grid1_units
+      endif
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlat_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlat_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcntrlon_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcntrlon_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlat_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdcrnrlon_id, 
+     &                          'units', 7, grid1_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlat_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdcrnrlon_id, 
+     &                          'units', 7, grid2_ctmp)
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid mask
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'mask_a', NF_INT,
+     &                     1, nc_srcgrdsize_id, nc_srcgrdimask_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdimask_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'mask_b', NF_INT,
+     &                     1, nc_dstgrdsize_id, nc_dstgrdimask_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdimask_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid area arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'area_a', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdarea_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdarea_id, 
+     &                          'units', 14, 'square radians')
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'area_b', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdarea_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdarea_id, 
+     &                          'units', 14, 'square radians')
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define grid fraction arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'frac_a', 
+     &                     NF_DOUBLE, 1, nc_srcgrdsize_id, 
+     &                     nc_srcgrdfrac_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_srcgrdfrac_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'frac_b', 
+     &                     NF_DOUBLE, 1, nc_dstgrdsize_id, 
+     &                     nc_dstgrdfrac_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_att_text (nc_file_id, nc_dstgrdfrac_id, 
+     &                          'units', 8, 'unitless')
+      call netcdf_error_handler(ncstat)
+
+      !***
+      !*** define mapping arrays
+      !***
+
+      ncstat = nf_def_var (nc_file_id, 'col', 
+     &                     NF_INT, 1, nc_numlinks_id, 
+     &                     nc_srcadd_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'row', 
+     &                     NF_INT, 1, nc_numlinks_id, 
+     &                     nc_dstadd_id)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_def_var (nc_file_id, 'S', 
+     &                     NF_DOUBLE, 1, nc_numlinks_id, 
+     &                     nc_rmpmatrix_id)
+      call netcdf_error_handler(ncstat)
+
+      if (num_wts > 1) then
+        nc_dims2_id(1) = nc_numwgts1_id
+        nc_dims2_id(2) = nc_numlinks_id
+
+        ncstat = nf_def_var (nc_file_id, 'S2', 
+     &                     NF_DOUBLE, 2, nc_dims2_id, 
+     &                     nc_rmpmatrix2_id)
+        call netcdf_error_handler(ncstat)
+      endif
+
+      !***
+      !*** end definition stage
+      !***
+
+      ncstat = nf_enddef(nc_file_id)
+      call netcdf_error_handler(ncstat)
+
+!-----------------------------------------------------------------------
+!
+!     compute integer masks
+!
+!-----------------------------------------------------------------------
+
+      if (direction == 1) then
+        allocate (src_mask_int(grid1_size),
+     &            dst_mask_int(grid2_size))
+
+        where (grid2_mask)
+          dst_mask_int = 1
+        elsewhere
+          dst_mask_int = 0
+        endwhere
+
+        where (grid1_mask)
+          src_mask_int = 1
+        elsewhere
+          src_mask_int = 0
+        endwhere
+      else
+        allocate (src_mask_int(grid2_size),
+     &            dst_mask_int(grid1_size))
+
+        where (grid1_mask)
+          dst_mask_int = 1
+        elsewhere
+          dst_mask_int = 0
+        endwhere
+
+        where (grid2_mask)
+          src_mask_int = 1
+        elsewhere
+          src_mask_int = 0
+        endwhere
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     change units of lat/lon coordinates if input units different
+!     from radians. if this is the second mapping, the conversion has
+!     alread been done.
+!
+!-----------------------------------------------------------------------
+
+      if (grid1_units(1:7) == 'degrees' .and. direction == 1) then
+        grid1_center_lat = grid1_center_lat/deg2rad
+        grid1_center_lon = grid1_center_lon/deg2rad
+        grid1_corner_lat = grid1_corner_lat/deg2rad
+        grid1_corner_lon = grid1_corner_lon/deg2rad
+      endif
+
+      if (grid2_units(1:7) == 'degrees' .and. direction == 1) then
+        grid2_center_lat = grid2_center_lat/deg2rad
+        grid2_center_lon = grid2_center_lon/deg2rad
+        grid2_corner_lat = grid2_corner_lat/deg2rad
+        grid2_corner_lon = grid2_corner_lon/deg2rad
+      endif
+
+!-----------------------------------------------------------------------
+!
+!     write mapping data
+!
+!-----------------------------------------------------------------------
+
+      if (direction == 1) then
+        itmp1 = nc_srcgrddims_id
+        itmp2 = nc_dstgrddims_id
+      else
+        itmp2 = nc_srcgrddims_id
+        itmp1 = nc_dstgrddims_id
+      endif
+
+      ncstat = nf_put_var_int(nc_file_id, itmp1, grid1_dims)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_int(nc_file_id, itmp2, grid2_dims)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_int(nc_file_id, nc_srcgrdimask_id, 
+     &                        src_mask_int)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_int(nc_file_id, nc_dstgrdimask_id,
+     &                        dst_mask_int)
+      call netcdf_error_handler(ncstat)
+
+      deallocate(src_mask_int, dst_mask_int)
+
+      if (direction == 1) then
+        itmp1 = nc_srcgrdcntrlat_id
+        itmp2 = nc_srcgrdcntrlon_id
+        itmp3 = nc_srcgrdcrnrlat_id
+        itmp4 = nc_srcgrdcrnrlon_id
+      else
+        itmp1 = nc_dstgrdcntrlat_id
+        itmp2 = nc_dstgrdcntrlon_id
+        itmp3 = nc_dstgrdcrnrlat_id
+        itmp4 = nc_dstgrdcrnrlon_id
+      endif
+
+      ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_center_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_center_lon)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp3, grid1_corner_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp4, grid1_corner_lon)
+      call netcdf_error_handler(ncstat)
+
+      if (direction == 1) then
+        itmp1 = nc_dstgrdcntrlat_id
+        itmp2 = nc_dstgrdcntrlon_id
+        itmp3 = nc_dstgrdcrnrlat_id
+        itmp4 = nc_dstgrdcrnrlon_id
+      else
+        itmp1 = nc_srcgrdcntrlat_id
+        itmp2 = nc_srcgrdcntrlon_id
+        itmp3 = nc_srcgrdcrnrlat_id
+        itmp4 = nc_srcgrdcrnrlon_id
+      endif
+
+      ncstat = nf_put_var_double(nc_file_id, itmp1, grid2_center_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid2_center_lon)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_corner_lat)
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_corner_lon)
+      call netcdf_error_handler(ncstat)
+
+      if (direction == 1) then
+        itmp1 = nc_srcgrdarea_id
+        itmp2 = nc_srcgrdfrac_id
+        itmp3 = nc_dstgrdarea_id
+        itmp4 = nc_dstgrdfrac_id
+      else
+        itmp1 = nc_dstgrdarea_id
+        itmp2 = nc_dstgrdfrac_id
+        itmp3 = nc_srcgrdarea_id
+        itmp4 = nc_srcgrdfrac_id
+      endif
+
+      if (luse_grid1_area) then
+        ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area_in)
+      else
+        ncstat = nf_put_var_double(nc_file_id, itmp1, grid1_area)
+      endif
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp2, grid1_frac)
+      call netcdf_error_handler(ncstat)
+
+      if (luse_grid2_area) then
+        ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area)
+      else
+        ncstat = nf_put_var_double(nc_file_id, itmp3, grid2_area)
+      endif
+      call netcdf_error_handler(ncstat)
+
+      ncstat = nf_put_var_double(nc_file_id, itmp4, grid2_frac)
+      call netcdf_error_handler(ncstat)
+
+      if (direction == 1) then
+        ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, 
+     &                          grid1_add_map1)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, 
+     &                          grid2_add_map1)
+        call netcdf_error_handler(ncstat)
+
+        if (num_wts == 1) then
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                               wts_map1)
+          call netcdf_error_handler(ncstat)
+        else
+          allocate(wts1(num_links_map1),wts2(num_wts-1,num_links_map1))
+
+          wts1 = wts_map1(1,:)
+          wts2 = wts_map1(2:,:)
+
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                               wts1)
+          call netcdf_error_handler(ncstat)
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, 
+     &                               wts2)
+          call netcdf_error_handler(ncstat)
+          deallocate(wts1,wts2)
+        endif
+      else
+        ncstat = nf_put_var_int(nc_file_id, nc_srcadd_id, 
+     &                          grid2_add_map2)
+        call netcdf_error_handler(ncstat)
+
+        ncstat = nf_put_var_int(nc_file_id, nc_dstadd_id, 
+     &                          grid1_add_map2)
+        call netcdf_error_handler(ncstat)
+
+        if (num_wts == 1) then
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                               wts_map2)
+          call netcdf_error_handler(ncstat)
+        else
+          allocate(wts1(num_links_map2),wts2(num_wts-1,num_links_map2))
+
+          wts1 = wts_map2(1,:)
+          wts2 = wts_map2(2:,:)
+
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix_id, 
+     &                               wts1)
+          call netcdf_error_handler(ncstat)
+          ncstat = nf_put_var_double(nc_file_id, nc_rmpmatrix2_id, 
+     &                               wts2)
+          call netcdf_error_handler(ncstat)
+          deallocate(wts1,wts2)
+        endif
+      endif
+
+      ncstat = nf_close(nc_file_id)
+      call netcdf_error_handler(ncstat)
+
+!-----------------------------------------------------------------------
+
+      end subroutine write_remap_csm
+
+!***********************************************************************
+
+      end module remap_write
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Index: CPL/oasis3/trunk/src/lib/scrip/src/rotations.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/rotations.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/rotations.F90	(revision 1677)
@@ -0,0 +1,331 @@
+MODULE rotations
+!-----------------------------------------------------------------------
+
+  USE kinds_mod             ! defines common data types      
+  USE constants             ! defines common constants      
+  USE mod_parameter
+  USE mod_unit
+  USE mod_printing  
+  USE mod_unitncdf
+  
+  IMPLICIT NONE
+
+#include <netcdf.inc>
+  
+  REAL (KIND=dbl_kind), PARAMETER :: &
+     rp_deg2rad = pi/180.            ! Conversion from degrees to radians
+
+!
+!  This module contains necessary routines for transformations between 
+!  the referentials Cartesian, spheric and streched spheric.
+!
+
+!  History:
+!  --------
+!  E. Rapaport     2004/03     Created
+! 
+
+CONTAINS
+
+!-----------------------------------------------------------------------
+
+  SUBROUTINE angel(cd_grd_name, id_grd_size, &
+       rda_sin_alpha, rda_cos_alpha)
+
+    CHARACTER (LEN=8), INTENT(in) :: &
+         cd_grd_name     ! grid name
+         
+    INTEGER (KIND=int_kind), INTENT(in) :: &
+         id_grd_size     ! grid size
+ 
+    CHARACTER(LEN=8) :: &
+         name_ang        ! name of the angle valew in grids.nc
+                             
+    REAL (KIND=dbl_kind), DIMENSION (:), ALLOCATABLE :: &
+         rla_alpha       ! the angel between the direction j in streched and the 
+                         ! north-south in spheric coordonate system
+        
+    INTEGER (KIND=int_kind) :: &
+         il_stat, il_varid, il_vtype, &     ! netcdf variables
+         icount, ilenstr, i
+
+!RETURN VALUE:
+
+    REAL (KIND=dbl_kind), DIMENSION(id_grd_size), INTENT(out) :: &
+         rda_sin_alpha,&     ! the sinus and cosinus for the angel between the 
+         rda_cos_alpha       ! direction j in streched and the north-south 
+                             ! in spheric
+    
+! !DESCRIPTION:
+!
+!  This routine finds the cosinus and sinus of the angle between the
+!  north-south direction in a spheric referential and the direction
+!  of gridlines j in a streched spheric referential. 
+!  If there is no angel information in file grids.nc we stop.
+!
+
+    IF (nlogprt .GE. 2) THEN
+	WRITE (UNIT = nulou,FMT = *) ' '
+	WRITE (UNIT = nulou,FMT = *) &
+	   '           ROUTINE angel  -  Level ?'
+	WRITE (UNIT = nulou,FMT = *) ' '
+        CALL FLUSH(nulou)
+    ENDIF
+
+    IF (lncdfgrd) THEN
+       icount = ilenstr(cd_grd_name,jpeight)
+       name_ang = cd_grd_name(1:icount)//'.ang'
+
+       CALL hdlerr &
+            (NF_OPEN('grids.nc',NF_NOWRITE,nc_grdid),'angel')
+
+       il_stat = NF_INQ_VARID(nc_grdid, name_ang, il_varid)
+
+       IF (il_stat < 0) THEN
+          WRITE (UNIT = nulou,FMT = *) &
+	       'File grids.nc contains no angle information,'
+          WRITE (UNIT = nulou,FMT = *) &
+	       'OASIS will stop'        
+          STOP
+       ELSE IF (il_stat == 0) THEN
+!
+!** Get angle information from file grids.nc
+!
+          ALLOCATE(rla_alpha(id_grd_size))
+       
+          CALL hdlerr(NF_GET_VAR_DOUBLE &
+               (nc_grdid, il_varid, rla_alpha),'angel') 
+
+          rda_sin_alpha(:) = SIN(rp_deg2rad*rla_alpha(:))	 
+          rda_cos_alpha(:) = COS(rp_deg2rad*rla_alpha(:))
+       
+          DEALLOCATE(rla_alpha)
+       END IF
+    ELSE
+       il_stat = -1
+    END IF
+
+       IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) &
+               '          --------- End of routine angel ---------'
+          CALL FLUSH (nulou)
+       ENDIF
+
+     END SUBROUTINE angel
+!
+!-----------------------------------------------------------------------
+!
+     SUBROUTINE loc2spher(cd_grd_name, id_grd_size, rda_trans)
+          
+       CHARACTER (LEN=8),INTENT(in) :: &
+            cd_grd_name      ! grid name      
+    
+       INTEGER (KIND=int_kind), INTENT(in) :: &
+            id_grd_size      ! grid size
+ 
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: &
+            rla_sin_alpha, &    ! the sinus and cosinus for the angel between the 
+            rla_cos_alpha       ! direction j in streched and the north-south 
+                                ! in spheric
+! !RETURN VALUE:
+
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size,2,2), INTENT(out) :: &
+            rda_trans
+     
+! !DESCRIPTION:
+!
+!  This routine finds the transformation matrix between a local stretched 
+!  spheric referential and a regulier spheric referential.
+!
+
+       IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) &
+               '           ROUTINE loc2spher  -  Level ?'
+          CALL FLUSH(nulou)
+       ENDIF
+!
+!*Find the angle between the two referentials
+!
+       CALL angel(cd_grd_name, id_grd_size, &
+            rla_sin_alpha, rla_cos_alpha)	     
+
+       rda_trans(:,1,1) =  rla_cos_alpha 
+       rda_trans(:,2,1) =  rla_sin_alpha
+       rda_trans(:,1,2) =  -rla_sin_alpha 
+       rda_trans(:,2,2) =  rla_cos_alpha
+	
+       IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) &
+               '          --------- End of routine loc2spher ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH(nulou)
+       ENDIF
+
+     END SUBROUTINE loc2spher
+! 
+!-----------------------------------------------------------------------
+! 
+     SUBROUTINE spher2loc(cd_grd_name, id_grd_size, rda_trans)
+     
+       CHARACTER (LEN=8),INTENT(in) :: &
+            cd_grd_name       ! grid name      
+   
+       INTEGER (KIND=int_kind), INTENT(in) :: &
+            id_grd_size       ! grid size
+
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: &
+            rla_sin_alpha, &  ! the sinus and cosinus for the angel between the 
+            rla_cos_alpha     ! direction j in streched and the north-south in spheric
+   
+!*RETURN VALUE:
+   
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size,3,3), INTENT(out) :: rda_trans
+      
+!*DESCRIPTION:
+!  Finds the transformation matrix between a spheric and a stretched 
+!  spheric referential. 
+!
+
+       IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) &
+	   '           ROUTINE spher2loc  -  Level ?'
+          CALL FLUSH(nulou)
+       ENDIF
+!
+!*Find the angle between the two referentials
+!     
+       CALL angel(cd_grd_name, id_grd_size, &
+            rla_sin_alpha, rla_cos_alpha)	  
+
+       rda_trans(:,1,1) =  rla_cos_alpha 
+       rda_trans(:,2,1) =  -rla_sin_alpha
+       rda_trans(:,1,2) = rla_sin_alpha
+       rda_trans(:,2,2) =  rla_cos_alpha
+
+       rda_trans(:,1,3) = 0.
+       rda_trans(:,2,3) = 0.
+       rda_trans(:,3,1) = 0.
+       rda_trans(:,3,2) = 0.
+       rda_trans(:,3,3) = 1.
+
+       IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) &
+               '          --------- End of routine spher2loc ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH(nulou)
+       ENDIF
+
+     END SUBROUTINE spher2loc    
+!
+!-----------------------------------------------------------------------
+! 
+     SUBROUTINE spher2car(rda_grd_lon, rda_grd_lat, id_grd_size, rda_trans)
+
+       INTEGER (KIND=int_kind), INTENT(in) :: &
+            id_grd_size                    ! grid size
+    
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size),INTENT(in) :: &
+            rda_grd_lon, &                 ! grid longitudes
+            rda_grd_lat                    ! grid latitudes
+    
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: &
+            rla_sin_lon, rla_cos_lon, &    ! sinus and cosinus for longitudes
+            rla_sin_lat, rla_cos_lat       ! sinus and cosinus for latitudes
+
+! !RETURN VALUE:
+  
+       REAL (KIND=dbl_kind), DIMENSION(id_grd_size,3,2), INTENT(out) :: rda_trans 
+   
+! !DESCRIPTION:
+!  Finds the rotation matrix between a spheric and cartesien referentails.
+!
+
+    IF (nlogprt .GE. 2) THEN
+	WRITE (UNIT = nulou,FMT = *) ' '
+	WRITE (UNIT = nulou,FMT = *) &
+	   '           ROUTINE   - spher2car Level ?'
+	WRITE (UNIT = nulou,FMT = *) ' '
+        CALL FLUSH(nulou)
+    ENDIF
+
+    rla_sin_lon(:) = SIN(rda_grd_lon(:) * rp_deg2rad)
+    rla_cos_lon(:) = COS(rda_grd_lon(:) * rp_deg2rad)
+    rla_sin_lat(:) = SIN(rda_grd_lat(:) * rp_deg2rad)
+    rla_cos_lat(:) = COS(rda_grd_lat(:) * rp_deg2rad)
+
+    rda_trans(:,1,1) = -rla_sin_lon(:)
+    rda_trans(:,2,1) = -rla_sin_lat(:) * rla_cos_lon(:)
+    rda_trans(:,1,2) =  rla_cos_lon(:)
+    rda_trans(:,2,2) = -rla_sin_lat(:) * rla_sin_lon(:)
+    rda_trans(:,3,1) = rla_cos_lon(:) * rla_cos_lat(:) 
+    rda_trans(:,3,2) = rla_cos_lat(:) * rla_sin_lon(:)
+ 
+    IF (nlogprt .GE. 2) THEN
+	WRITE (UNIT = nulou,FMT = *) ' '
+	WRITE (UNIT = nulou,FMT = *) &
+	   '          --------- End of routine spher2car ---------'
+	CALL FLUSH (nulou)
+    ENDIF
+
+  END SUBROUTINE spher2car
+!
+!-----------------------------------------------------------------------
+! 
+  SUBROUTINE car2spher(rda_grd_lon, rda_grd_lat, id_grd_size, rda_trans)
+
+    INTEGER (KIND=int_kind), INTENT(in) :: &
+         id_grd_size                    ! grid size
+    
+    REAL (KIND=dbl_kind), DIMENSION(id_grd_size),INTENT(in) :: &
+         rda_grd_lon, &                 ! grid longitudes
+         rda_grd_lat                    ! grid latitudes
+
+    REAL (KIND=dbl_kind), DIMENSION(id_grd_size) :: &
+         rla_sin_lon, rla_cos_lon, &    ! sinus and cosinu for longitudes
+         rla_sin_lat, rla_cos_lat       ! sinus and cosinu for latitudes
+
+! !RETURN VALUE:
+
+    REAL (KIND=dbl_kind), DIMENSION(id_grd_size,3,3), INTENT(out) :: rda_trans
+    
+! !DESCRIPTION:
+!  Finds the rotation matrix between a cartesien and a spheric referential.
+!
+  
+    IF (nlogprt .GE. 2) THEN
+	WRITE (UNIT = nulou,FMT = *) ' '
+	WRITE (UNIT = nulou,FMT = *) &
+	   '           ROUTINE   - car2spher Level ?'
+	WRITE (UNIT = nulou,FMT = *) ' '
+        CALL FLUSH(nulou)
+    ENDIF
+ 
+    rla_sin_lon(:) = SIN(rda_grd_lon(:) * rp_deg2rad)
+    rla_cos_lon(:) = COS(rda_grd_lon(:) * rp_deg2rad)
+    rla_sin_lat(:) = SIN(rda_grd_lat(:) * rp_deg2rad)
+    rla_cos_lat(:) = COS(rda_grd_lat(:) * rp_deg2rad)
+    
+    rda_trans(:,1,1) =  -rla_sin_lon(:)
+    rda_trans(:,2,1) =   rla_cos_lon(:)  
+    rda_trans(:,3,1) =   0.
+    rda_trans(:,1,2) =  -rla_sin_lat(:) * rla_cos_lon(:)
+    rda_trans(:,2,2) =  -rla_sin_lat(:) * rla_sin_lon(:)  
+    rda_trans(:,3,2) =   rla_cos_lat(:)
+    rda_trans(:,1,3) =   rla_cos_lat(:) * rla_cos_lon(:)
+    rda_trans(:,2,3) =   rla_cos_lat(:) * rla_sin_lon(:)
+    rda_trans(:,3,3) =   rla_sin_lat(:)
+
+    IF (nlogprt .GE. 2) THEN
+	WRITE (UNIT = nulou,FMT = *) ' '
+	WRITE (UNIT = nulou,FMT = *) &
+	   '          --------- End of routine car2spher ---------'
+	CALL FLUSH (nulou)
+    ENDIF
+
+  END SUBROUTINE car2spher
+
+
+END MODULE rotations
Index: CPL/oasis3/trunk/src/lib/scrip/src/scrip.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/scrip.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/scrip.f	(revision 1677)
@@ -0,0 +1,492 @@
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C****
+C***********************************************************************
+C     This routine belongs to the SCRIP library. It is modified to run
+C     within OASIS.
+C     Modifications:
+C       - routine does not read namelist but gets parameters from the
+C         calling routine scriprmp.f
+C       - map-method and noralize-option are written in capital letters
+C       - routine grid_init is not called from scrip any more but was
+C         called earlier from scriprmp
+C       - call of two extra routines: free_grids and free_remap_vars to 
+C         allow multiple calls of SCRIP
+C       - added case for GAUSWGT 
+C       - added 'REDUCED' case for bilinear and bicubic.
+C       - hard coded num_maps=1 for USE in OASIS
+C       - added lextrapdone argument
+C
+C     Modified by            V. Gayler,  M&D                  20.09.2001
+C     Modified by            D. Declat,  CERFACS              27.06.2002
+C     Modified by            S. Valcke,  CERFACS              27.08.2002
+C***********************************************************************
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This routine is the driver for computing the addresses and weights 
+!     for interpolating between two grids on a sphere.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: scrip.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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.
+!
+!***********************************************************************
+
+      subroutine scrip
+     $           (interp_file1, map1_name, m_method, n_opt, 
+     $            lextrapdone, rl_varmul, id_scripvoi)
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod                  ! module defining data types
+      use constants                  ! module for common constants
+      use iounits                    ! I/O unit manager
+      use timers                     ! CPU timers
+      use grids                      ! module with grid information
+      use remap_vars                 ! common remapping variables
+      use remap_conservative         ! routines for conservative remap
+      use remap_distance_weight      ! routines for dist-weight remap
+      use remap_gaussian_weight      ! routines for gaus-weight remap
+      use remap_bilinear             ! routines for bilinear interp
+      use remap_bicubic              ! routines for bicubic  interp
+      use remap_bilinear_reduced     ! routines for bilinear interp
+      use remap_bicubic_reduced      ! routines for bicubic interp
+      use remap_write                ! routines for remap output
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     input variables
+!
+!-----------------------------------------------------------------------
+
+      character (char_len), intent(in) ::
+     &           interp_file1, ! filename for output remap data (map1)
+     &           map1_name     ! name for mapping from grid1 to grid2
+
+      character*8, intent(in) ::
+     &           m_method,     ! choice for mapping method
+     &           n_opt         ! option for normalizing weights
+
+      LOGICAL ::
+     &           lextrapdone   ! logical, true if EXTRAP done on field
+
+      REAL (kind=real_kind) ::
+     &    rl_varmul             ! Gaussian variance (for GAUSWGT)
+
+      INTEGER (kind=int_kind) ::
+     &     id_scripvoi          ! number of neighbours for DISTWGT and GAUSWGT
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) ::
+     &           n             ! dummy counter
+
+      character (char_len) ::
+     &           interp_file2, ! filename for output remap data (map2)
+     &           map2_name,    ! name for mapping from grid2 to grid1
+     &           output_opt,   ! option for output conventions
+     &           map_method,   ! choice for mapping method
+     &           normalize_opt ! option for normalizing weights
+
+!-----------------------------------------------------------------------
+!
+!     initialize timers
+!
+!-----------------------------------------------------------------------
+
+      call timers_init
+      do n=1,max_timers
+        call timer_clear(n)
+      end do
+
+!-----------------------------------------------------------------------
+!
+!     initialize variables of former SCRIP namelist
+!
+!-----------------------------------------------------------------------
+
+      interp_file2  = 'unknown'
+      map2_name     = 'unknown'
+      luse_grid1_area = .false.
+      luse_grid2_area = .false.
+      num_maps      = 1
+      output_opt    = 'scrip'
+
+      map_method = m_method
+      normalize_opt = n_opt
+
+      select case(map_method)
+      case ('CONSERV')
+        map_type = map_type_conserv
+      case ('BILINEAR')
+        map_type = map_type_bilinear
+      case ('BICUBIC')
+        map_type = map_type_bicubic
+      case ('DISTWGT')
+        map_type = map_type_distwgt
+      case ('GAUSWGT')
+        map_type = map_type_gauswgt
+      case default
+        stop 'unknown mapping method'
+      end select
+
+      select case(normalize_opt(1:4))
+      case ('NONE')
+        norm_opt = norm_opt_none
+      case ('FRAC')
+        norm_opt = norm_opt_frcarea
+      case ('DEST')
+        norm_opt = norm_opt_dstarea
+      CASE ('NONO')
+        norm_opt = norm_opt_nonorm
+      case default
+        stop 'unknown normalization option'
+      end select
+
+      write(stdout, *) ' Computing remappings between: ',grid1_name
+      write(stdout, *) '                          and  ',grid2_name
+
+!-----------------------------------------------------------------------
+!
+!     initialize some remapping variables.
+!
+!-----------------------------------------------------------------------
+
+      call init_remap_vars (id_scripvoi)
+
+!-----------------------------------------------------------------------
+!
+!     call appropriate interpolation setup routine based on type of
+!     remapping requested.
+!
+!-----------------------------------------------------------------------
+
+      select case(map_type)
+      case(map_type_conserv)
+          call remap_conserv
+      case(map_type_bilinear)
+          IF (restrict_TYPE == 'REDUCED') then
+              call remap_bilin_reduced (lextrapdone)
+          ELSE
+              call remap_bilin (lextrapdone)
+          endif
+      case(map_type_distwgt)
+          call remap_distwgt (lextrapdone, id_scripvoi)
+      case(map_type_gauswgt)
+          call remap_gauswgt (lextrapdone, id_scripvoi, rl_varmul)
+      case(map_type_bicubic)
+          IF (restrict_TYPE == 'REDUCED') then
+              call remap_bicub_reduced (lextrapdone)
+          ELSE
+              call remap_bicub (lextrapdone)
+          endif
+       case default
+           stop 'Invalid Map Type'
+      end select
+      CALL sort_add(grid2_add_map1, grid1_add_map1, wts_map1,
+     $   num_links_map1, num_wts)
+      IF (lfracnnei) THEN
+          CALL fracnnei(grid1_size, grid2_size, grid1_mask, grid2_mask,
+     $        grid1_center_lon, grid1_center_lat,
+     $        grid2_center_lon, grid2_center_lat,
+     $        num_links_map1, num_wts,
+     $        wts_map1, grid1_add_map1, grid2_add_map1)
+          lfracnnei = .false.
+      ENDIF
+
+!-----------------------------------------------------------------------
+!
+!     reduce size of remapping arrays and then write remapping info
+!     to a file.
+!
+!-----------------------------------------------------------------------
+      if (num_links_map1 /= max_links_map1) then
+        call resize_remap_vars(1, num_links_map1-max_links_map1)
+      endif
+      if ((num_maps > 1) .and. (num_links_map2 /= max_links_map2)) then
+        call resize_remap_vars(2, num_links_map2-max_links_map2)
+      endif
+      call write_remap(map1_name, map2_name, 
+     &                 interp_file1, interp_file2, output_opt)
+
+!-----------------------------------------------------------------------
+!
+!     deallocate allocatable arrays
+!
+!-----------------------------------------------------------------------
+
+      call free_grids
+      call free_remap_vars
+
+!-----------------------------------------------------------------------
+
+      end subroutine scrip
+!
+      subroutine sort_add(add1, add2, weights, num_links, num_wts)
+
+!-----------------------------------------------------------------------
+!
+!     this routine sorts address and weight arrays based on the
+!     destination address with the source address as a secondary
+!     sorting criterion.  the method is a standard heap sort.
+!
+!-----------------------------------------------------------------------
+
+      use kinds_mod     ! defines common data types
+      use constants     ! defines common scalar constants
+
+
+      implicit none
+
+!-----------------------------------------------------------------------
+!
+!     Input and Output arrays
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) :: num_links, num_wts
+      integer (kind=int_kind), intent(inout), dimension(num_links) ::
+     &        add1,       ! destination address array (num_links)
+     &        add2        ! source      address array
+
+      real (kind=dbl_kind), intent(inout),
+     &    dimension(num_wts, num_links) ::
+     &        weights     ! remapping weights (num_wts, num_links)
+
+
+!-----------------------------------------------------------------------
+!
+!     local variables
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) ::
+!     &          num_links,          ! num of links for this mapping
+!     &          num_wts,            ! num of weights for this mapping
+     &          add1_tmp, add2_tmp, ! temp for addresses during swap
+     &          nwgt,
+     &          lvl, final_lvl,     ! level indexes for heap sort levels
+     &          chk_lvl1, chk_lvl2, max_lvl
+
+      real (kind=dbl_kind), dimension(SIZE(weights,DIM=1)) ::
+     &          wgttmp              ! temp for holding wts during swap
+
+!-----------------------------------------------------------------------
+!
+!     determine total number of links to sort and number of weights
+!
+!-----------------------------------------------------------------------
+
+!      num_links = SIZE(add1)
+!      num_wts   = SIZE(weights, DIM=1)
+
+!-----------------------------------------------------------------------
+!
+!     start at the lowest level (N/2) of the tree and sift lower 
+!     values to the bottom of the tree, promoting the larger numbers
+!
+!-----------------------------------------------------------------------
+
+      do lvl=num_links/2,1,-1
+
+        final_lvl = lvl
+        add1_tmp = add1(lvl)
+        add2_tmp = add2(lvl)
+        wgttmp(:) = weights(:,lvl)
+
+        !***
+        !*** loop until proper level is found for this link, or reach
+        !*** bottom
+        !***
+
+        sift_loop1: do
+
+          !***
+          !*** find the largest of the two daughters
+          !***
+
+          chk_lvl1 = 2*final_lvl
+          chk_lvl2 = 2*final_lvl+1
+          if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1
+
+          if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR.
+     &       ((add1(chk_lvl1) == add1(chk_lvl2)) .AND.
+     &        (add2(chk_lvl1) >  add2(chk_lvl2)))) then
+            max_lvl = chk_lvl1
+          else 
+            max_lvl = chk_lvl2
+          endif
+
+          !***
+          !*** if the parent is greater than both daughters,
+          !*** the correct level has been found
+          !***
+
+          if ((add1_tmp .GT. add1(max_lvl)) .OR.
+     &       ((add1_tmp .EQ. add1(max_lvl)) .AND.
+     &        (add2_tmp .GT. add2(max_lvl)))) then
+            add1(final_lvl) = add1_tmp
+            add2(final_lvl) = add2_tmp
+            weights(:,final_lvl) = wgttmp(:)
+            exit sift_loop1
+
+          !***
+          !*** otherwise, promote the largest daughter and push
+          !*** down one level in the tree.  if haven't reached
+          !*** the end of the tree, repeat the process.  otherwise
+          !*** store last values and exit the loop
+          !***
+
+          else 
+            add1(final_lvl) = add1(max_lvl)
+            add2(final_lvl) = add2(max_lvl)
+            weights(:,final_lvl) = weights(:,max_lvl)
+
+            final_lvl = max_lvl
+            if (2*final_lvl > num_links) then
+              add1(final_lvl) = add1_tmp
+              add2(final_lvl) = add2_tmp
+              weights(:,final_lvl) = wgttmp(:)
+              exit sift_loop1
+            endif
+          endif
+        end do sift_loop1
+      end do
+
+!-----------------------------------------------------------------------
+!
+!     now that the heap has been sorted, strip off the top (largest)
+!     value and promote the values below
+!
+!-----------------------------------------------------------------------
+
+      do lvl=num_links,3,-1
+
+        !***
+        !*** move the top value and insert it into the correct place
+        !***
+
+        add1_tmp = add1(lvl)
+        add1(lvl) = add1(1)
+
+        add2_tmp = add2(lvl)
+        add2(lvl) = add2(1)
+
+        wgttmp(:) = weights(:,lvl)
+        weights(:,lvl) = weights(:,1)
+
+        !***
+        !*** as above this loop sifts the tmp values down until proper 
+        !*** level is reached
+        !***
+
+        final_lvl = 1
+
+        sift_loop2: do
+
+          !***
+          !*** find the largest of the two daughters
+          !***
+
+          chk_lvl1 = 2*final_lvl
+          chk_lvl2 = 2*final_lvl+1
+          if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1
+
+          if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR.
+     &       ((add1(chk_lvl1) == add1(chk_lvl2)) .AND.
+     &        (add2(chk_lvl1) >  add2(chk_lvl2)))) then
+            max_lvl = chk_lvl1
+          else 
+            max_lvl = chk_lvl2
+          endif
+
+          !***
+          !*** if the parent is greater than both daughters,
+          !*** the correct level has been found
+          !***
+
+          if ((add1_tmp >  add1(max_lvl)) .OR.
+     &       ((add1_tmp == add1(max_lvl)) .AND.
+     &        (add2_tmp >  add2(max_lvl)))) then
+            add1(final_lvl) = add1_tmp
+            add2(final_lvl) = add2_tmp
+            weights(:,final_lvl) = wgttmp(:)
+            exit sift_loop2
+
+          !***
+          !*** otherwise, promote the largest daughter and push
+          !*** down one level in the tree.  if haven't reached
+          !*** the end of the tree, repeat the process.  otherwise
+          !*** store last values and exit the loop
+          !***
+
+          else 
+            add1(final_lvl) = add1(max_lvl)
+            add2(final_lvl) = add2(max_lvl)
+            weights(:,final_lvl) = weights(:,max_lvl)
+
+            final_lvl = max_lvl
+            if (2*final_lvl >= lvl) then
+              add1(final_lvl) = add1_tmp
+              add2(final_lvl) = add2_tmp
+              weights(:,final_lvl) = wgttmp(:)
+              exit sift_loop2
+            endif
+          endif
+        end do sift_loop2
+      end do
+
+      !***
+      !*** swap the last two entries
+      !***
+
+
+      add1_tmp = add1(2)
+      add1(2)  = add1(1)
+      add1(1)  = add1_tmp
+
+      add2_tmp = add2(2)
+      add2(2)  = add2(1)
+      add2(1)  = add2_tmp
+
+      wgttmp (:)   = weights(:,2)
+      weights(:,2) = weights(:,1)
+      weights(:,1) = wgttmp (:)
+
+!-----------------------------------------------------------------------
+
+      end subroutine sort_add
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/lib/scrip/src/scriprmp.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/scriprmp.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/scriprmp.f	(revision 1677)
@@ -0,0 +1,622 @@
+      SUBROUTINE scriprmp (dst_array, src_array, src_size, dst_size, 
+     $                     src_mask, dst_mask,
+     $                     src_lon, src_lat, nlon_src, nlat_src, 
+     $                     dst_lon, dst_lat, nlon_dst, nlat_dst, 
+     $                     map_method, cdgrdtyp, id_nosper, 
+     $                     src_name, dst_name, 
+     $                     normalize_opt, order, rst_type, n_srch_bins,
+     $                     lextrapdone, rl_varmul, id_scripvoi)
+C*****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *scriprmp* - SCRIP remapping
+C
+C     Purpose:
+C     -------
+C     Main routine of SCRIP remapping
+C        - finds out, whether remapping matrix exists
+C        - drives calculation of missing remapping matrices
+C        - performs matrix multiplication
+C
+C     Interface:
+C     ---------
+C       *CALL*  *scriprmp (dst_array, src_array, src_size, dst_size, 
+C                          src_mask, dst_mask, 
+C                          src_lon, src_lat, nlon_src, nlat_src,
+C                          dst_lon, dst_lat, nlon_dst, nlat_dst, 
+C                          map_method, cdgrdtyp, id_nosper,
+C                          src_name, dst_name, 
+C                          normalize_opt, order, rst_type, n_srch_bins,
+C                          lextrapdone, rl_varmul)
+C
+C     Called from:
+C     -----------
+C     interp
+C
+C     Input:
+C     -----
+C             src_array : field on source grid(real 1D)
+C             src_size  : source grid size (integer)
+C             dst_size  : target grid size (integer)
+C             src_mask  : source grid mask (INTEGER)
+C             dst_mask  : target grid mask (INTEGER)
+C             src_lon   : source grid longitudes (real 1D)
+C             src_lat   : source grid latitudes (real 1D)
+C             nlon_src  : number of source grid longitudes (integer)
+C             nlat_src  : number of source grid latitudes (integer)
+C             dst_lon   : target grid longitudes (real 1D)
+C             dst_lat   : target grid latitudes (real 1D)
+C             nlon_dst  : number of destination grid longitudes (integer)
+C             nlat_dst  : number of destination grid latitudes (integer)
+C             map_method: remapping method (character*8)
+C             cdgrdtyp  : source grid type (character*8)
+C             id_nosper : number of overlapping for source grid
+C             src_name  : source grid name (character*8)
+C             dst_name  : target grid name (character*8)
+C             normalize_opt: option for normalization (character*8)
+C             order     : order of conservative remapping (character*8)
+C             rst_type : type of scrip search restriction (character*8)
+C             n_srch_bins : number of seach bins (integer)
+C             lextrapdone : logical, true if EXTRAP done on field
+C             rl_varmul : Gaussian variance (for GAUSWGT)
+C             id_scripvoi : number of neighbour for DISTWGT and GAUSWGT
+C
+C     Output:
+C     ------
+C             dst_array : field on target grid (real 1D)
+C
+C     Externals:
+C     ---------
+C     corners, scrip, gradient, gradient_bilin
+C
+C     History:
+C     -------
+C       Version   Programmer     Date        Description
+C       -------   ----------     ----        -----------  
+C       2.0       V.Gayler       2001/11/09  created
+C       2.5       D.Declat       2002/07/08  completed
+C       2.5       D.Declat       2002/08/01  the mask of the tgt grid 
+C                                             taken into account
+C       2.5       D.Declat       2002/08/09  'NONE' and 'CONSERV' for conserv
+C                                            check pole
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C* ---------------------------- Modules used ----------------------------
+C
+      USE grids
+      USE remap_vars
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Implicit --------------------------------
+C
+      IMPLICIT NONE
+C
+C* ---------------------------- Include files ---------------------------
+C
+      INCLUDE 'netcdf.inc'
+      
+C
+C* ---------------------------- Intent In -------------------------------
+C
+      INTEGER (kind=int_kind) ::
+     $     nlon_src,            ! number of source grid longitudes
+     $     nlat_src,            ! number of source grid latitudes
+     $     nlon_dst,            ! number of destination grid longitudes
+     $     nlat_dst,            ! number of destination grid latitudes
+     $     src_size,            ! number of source grid cells
+     $     dst_size,            ! number of destination grid cells
+     $     n_srch_bins,         ! number of search bins fos SCRIP
+     $     src_mask(src_size),  ! source grid mask
+     $     dst_mask(dst_size),  ! target grid mask
+     $     id_nosper            ! number of overlapping points for source grid
+C
+      REAL (kind=real_kind) ::
+     $     src_array(src_size), ! source grid array
+     $     src_lon(src_size),   ! source grid longitudes
+     $     src_lat(src_size),   ! source grid latitudes
+     $     dst_lon(dst_size),   ! target grid longitudes
+     $     dst_lat(dst_size)   ! target grid latitudes
+C
+      CHARACTER*8 ::
+     $     map_method,          ! remapping method
+     $     cdgrdtyp,            ! source grid type
+     $     src_name,            ! source grid name
+     $     dst_name,            ! target grid name
+     $     normalize_opt,       ! option for normalization
+     $     order,               ! order of conservative remapping
+     $     rst_type             ! type of scrip search restriction
+C
+      LOGICAL ::
+     $     lextrapdone          ! logical, true if EXTRAP done on field
+C
+      REAL (kind=real_kind) ::
+     $     rl_varmul            ! Gaussian variance (for GAUSWGT)
+C
+      INTEGER (kind=int_kind) ::
+     $     id_scripvoi          ! number of neighbour for DISTWGT and GAUSWGT
+C
+C* ---------------------------- Intent Out -------------------------------
+C
+      REAL (kind=real_kind):: 
+     $     dst_array(dst_size)  ! array on destination grid
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*12 ::
+     $     cweight              ! string for weights
+C
+      CHARACTER*11 ::
+     $     csrcadd,             ! string for source grid addresses
+     $     cdstadd              ! string for destination grid addresses
+C
+      CHARACTER*13 ::
+     $     cdstare,             ! string for destination grid area
+     $     cdstfra              ! string for destination grid frac
+C
+      CHARACTER (char_len) ::
+     $     crmpfile,            ! name of the SCRIP matrix file
+     $     cmapping             ! mapping name
+C
+      INTEGER (kind=int_kind) ::
+     $     n,                   ! looping indicee
+     $     num_links,           ! number of intersections
+     $     ncrn_src, ncrn_dst,  ! number of grid cell corners
+     $     src_rank, dst_rank,  ! source / target grid rank
+     $     num_wgts,            ! number of weights
+     $     src_dims(2),         ! source grid dimensions
+     $     dst_dims(2),         ! target grid dimensions
+     $     sou_mask(src_size),   ! source grid mask
+     $     tgt_mask(dst_size)   ! target grid mask
+C
+      REAL (kind=real_kind) ::
+     $     dst_area(dst_size),  ! target grid area
+     $     dst_frac(dst_size),  ! target grid frac
+     $     dst_err(dst_size)    ! target grid error
+C
+C*    netCDF-declarations
+      INTEGER (kind=int_kind) ::
+     $     stat,                ! netCDF error status
+     $     nc_scpid,             ! file id
+     $     dimid,               ! dimension id
+     $     varid                ! variable id
+C
+      LOGICAL ::
+     $     lcalc                ! calculate matrix?
+C
+      INTEGER (kind=int_kind), DIMENSION(:), ALLOCATABLE :: 
+     $     src_addr,            ! addresses of source grid 
+     $     dst_addr             ! addresses of destination grid
+C
+      REAL (kind=real_kind), DIMENSION(:), ALLOCATABLE :: 
+     $     gradient_lat,        ! latitudinal gradient (conservative rmp.)
+     $     gradient_lon,        ! longitudinal gradient (conservative rmp.)
+     $     gradient_i,          ! gradient in i direction (bilinear rmp.)
+     $     gradient_j,          ! gradient in j direction (bilinear rmp.)
+     $     gradient_ij          ! cross gradient (bilinear rmp.)
+C
+      REAL (kind=real_kind), DIMENSION (:,:), ALLOCATABLE ::
+     $     weights              ! Remapping weights
+C
+      REAL (kind=real_kind), DIMENSION (:,:), ALLOCATABLE ::
+     $     src_corner_lon,      ! longitudes of source grid corners
+     $     src_corner_lat,      ! latitudes of source grid corners
+     $     dst_corner_lon,      ! longitudes of destination grid corners
+     $     dst_corner_lat       ! latitudes of destination grid corners
+C
+C*    pole contribution
+      REAL (kind=real_kind) ::
+     $     moy_tmp_S, moy_tmp_N, ! field average at the pole
+     $     moy_err_S, moy_err_N, ! error average at the pole
+     $     latpol_N, latpol_S     
+C
+      INTEGER (kind=int_kind) ::
+     $     compt_S, compt_N      ! number of cells representating a pole
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE scriprmp  -  Level ?'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' SCRIP remapping'
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+
+C
+C* -- get the name of the file containig the remapping matrix
+C
+      SELECT CASE (map_method)
+      CASE ('CONSERV')          ! conservative remapping
+       cmapping = 
+     $     src_name(1:4)//' to '//dst_name(1:4)//' '//map_method//
+     $     ' '//normalize_opt(1:4)//' remapping'
+
+       crmpfile = 
+     $      'rmp_'//src_name(1:4)//'_to_'//dst_name(1:4)//'_'//
+     $      map_method(1:7)//'_'//normalize_opt(1:8)//'.nc'
+      CASE DEFAULT
+       cmapping = 
+     $     src_name(1:4)//' to '//dst_name(1:4)//' '//map_method//
+     $     ' remapping'
+
+       crmpfile = 
+     $      'rmp_'//src_name(1:4)//'_to_'//dst_name(1:4)//'_'//
+     $      map_method(1:7)//'.nc'
+      END SELECT
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' SCRIP filename : ', crmpfile
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+
+C****
+C
+C* -- character strings of weights and addresses
+C
+      csrcadd = 'src_address'
+      cdstadd = 'dst_address'
+      cweight = 'remap_matrix'
+      cdstare = 'dst_grid_area'
+      cdstfra = 'dst_grid_frac'
+C
+C* -- logical to calculate matrix
+C
+      lcalc = .TRUE.
+C
+C* -- find out whether remapping file exists
+C
+      stat = NF_OPEN(crmpfile, NF_NOWRITE, nc_scpid)
+      IF (stat == NF_NOERR) THEN 
+         lcalc = .FALSE.
+C
+         IF (nlogprt .GE. 2) THEN
+             WRITE (UNIT = nulou,FMT = *) 
+     $       ' SCRIP file opened - no matrix calculation needed' 
+             WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+      ENDIF
+C
+C*    -- setting of the mask for the source AND the target grid
+C
+      WHERE (src_mask .eq. 1)
+          sou_mask = 0
+      END WHERE
+      WHERE (src_mask .eq. 0)
+          sou_mask = 1
+      END WHERE
+C
+      WHERE (dst_mask .eq. 1)
+          tgt_mask = 0
+      END WHERE
+      WHERE (dst_mask .eq. 0)
+          tgt_mask = 1
+      END WHERE
+
+      IF (lcalc) THEN           
+C
+C*    2. Calculate SCRIP remapping matrix
+C        --------------------------------
+C
+          SELECT CASE (normalize_opt)
+          CASE ('FRACNNEI')
+              normalize_opt = 'FRACAREA'
+              lfracnnei = .true.
+          END SELECT
+C
+          IF (nlogprt .GE. 2) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' Calculation of SCRIP remapping matrix: method = ',
+     $            map_method
+              WRITE (UNIT = nulou,FMT = *) ' '
+          ENDIF
+
+C*    -- get grid cell corners for conservative remapping
+C
+         ncrn_src = 4.
+         ncrn_dst = 4.
+C
+         IF (map_method == 'CONSERV') THEN
+C
+             ALLOCATE(src_corner_lon(ncrn_src,src_size),
+     $            src_corner_lat(ncrn_src,src_size),
+     $            dst_corner_lon(ncrn_dst,dst_size),
+     $            dst_corner_lat(ncrn_dst,dst_size))
+C
+            CALL corners(nlon_src, nlat_src, ncrn_src, src_lon, src_lat,
+     $           src_name, cdgrdtyp, src_corner_lon, src_corner_lat)
+            CALL corners(nlon_dst, nlat_dst, ncrn_dst, dst_lon, dst_lat,
+     $           dst_name, cdgrdtyp, dst_corner_lon, dst_corner_lat)
+         ENDIF
+C
+C*    -- initialization of grid arrays for SCRIP
+C
+         src_dims(1) = nlon_src
+         src_dims(2) = nlat_src
+         dst_dims(1) = nlon_dst
+         dst_dims(2) = nlat_dst
+         src_rank = 2
+         dst_rank = 2
+! Modifier car src_rank et dst_rank n'est pas toujours =2.
+C
+C
+         CALL grid_init(map_method, rst_type, n_srch_bins,
+     $                  src_size, dst_size, src_dims, dst_dims,
+     $                  src_rank, dst_rank, ncrn_src, ncrn_dst,
+     $                  sou_mask, tgt_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)
+
+C
+C*    -- calculation of weights and addresses using SCRIP-library
+C
+         CALL scrip(crmpfile, cmapping, map_method, normalize_opt,
+     $              lextrapdone, rl_varmul, id_scripvoi)
+C
+         IF (map_method == 'CONSERV') THEN
+             DEALLOCATE(src_corner_lon, src_corner_lat,
+     $              dst_corner_lon, dst_corner_lat)
+         ENDIF
+C
+C*    -- open just created SCRIP matrix file
+C         
+         CALL hdlerr(NF_OPEN
+     $              (crmpfile, NF_NOWRITE, nc_scpid), 'scriprmp')
+C
+         IF (nlogprt .GE. 2) THEN
+             WRITE (UNIT = nulou,FMT = *) 
+     $       ' SCRIP file created and opened' 
+             WRITE (UNIT = nulou,FMT = *) ' '
+             CALL FLUSH(nulou)
+         ENDIF
+      ENDIF
+C
+C*    3. Read weights and addresses
+C        --------------------------
+C
+C* -- get matrix size
+C
+      CALL hdlerr(NF_INQ_DIMID
+     $           (nc_scpid, 'num_links', dimid), 'scriprmp')
+      CALL hdlerr(NF_INQ_DIMLEN
+     $           (nc_scpid, dimid, num_links), 'scriprmp')
+C
+C* -- get number of weights
+C
+      SELECT CASE (map_method)
+      CASE ('CONSERV')          ! conservative remapping
+         num_wgts = 3.
+      CASE ('BILINEAR')         ! bilinear remapping
+         num_wgts = 1.
+      CASE ('BICUBIC')          ! bicubic remapping
+          IF (cdgrdtyp .eq. 'D') THEN
+              num_wgts = 1.
+          ELSE
+              num_wgts = 4.
+          ENDIF
+      CASE ('DISTWGT')          ! distance weighted averaging
+         num_wgts = 1.
+      CASE ('GAUSWGT')          ! distance gaussian weighted averaging
+         num_wgts = 1.
+      END SELECT
+C
+C* -- array allocation
+C
+      ALLOCATE (src_addr(num_links), dst_addr(num_links), 
+     $          weights(num_wgts,num_links))
+C
+C* -- read source grid addresses and weights
+C
+      CALL hdlerr(NF_INQ_VARID
+     $           (nc_scpid, csrcadd, varid), 'scriprmp')
+      CALL hdlerr(NF_GET_VAR_INT
+     $           (nc_scpid, varid, src_addr), 'scriprmp')
+      CALL hdlerr(NF_INQ_VARID
+     $           (nc_scpid, cdstadd, varid), 'scriprmp')
+      CALL hdlerr(NF_GET_VAR_INT
+     $           (nc_scpid, varid, dst_addr), 'scriprmp')
+      CALL hdlerr(NF_INQ_VARID
+     $           (nc_scpid, cweight, varid), 'scriprmp')
+      CALL hdlerr(NF_GET_VAR_DOUBLE
+     $           (nc_scpid, varid, weights), 'scriprmp') 
+      CALL hdlerr(NF_INQ_VARID
+     $           (nc_scpid, cdstare, varid), 'scriprmp')
+      CALL hdlerr(NF_GET_VAR_DOUBLE
+     $           (nc_scpid, varid, dst_area), 'scriprmp') 
+      CALL hdlerr(NF_INQ_VARID
+     $           (nc_scpid, cdstfra, varid), 'scriprmp')
+      CALL hdlerr(NF_GET_VAR_DOUBLE
+     $           (nc_scpid, varid, dst_frac), 'scriprmp') 
+C
+C*    4. Do the matrix multiplication
+C        ----------------------------
+C
+      SELECT CASE (map_method)
+C
+      CASE ('CONSERV')     ! conservative remapping 
+C
+          SELECT CASE (order)
+C
+          CASE ('FIRST')        ! first order remapping 
+C
+              DO n = 1, num_links
+                IF (src_addr(n) .ne. 0)
+     $           dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $                    + weights(1,n) * src_array(src_addr(n))
+              ENDDO
+C
+          CASE ('SECOND')       ! second order remapping 
+C                               ! (including gradients)
+              IF (cdgrdtyp .ne. 'LR') THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Field gradient cannot be calculated'
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'by Oasis as grid is not logically rectangular'
+                  CALL HALTE('STOP in scriprmp (CONSERV)')
+              ENDIF
+              ALLOCATE(gradient_lat(src_size), gradient_lon(src_size))
+C
+              call gradient(nlon_src, nlat_src, src_array, sou_mask,
+     $                       src_lat, src_lon, id_nosper,
+     $                       gradient_lat, gradient_lon)
+C
+              DO n = 1, num_links
+                IF (src_addr(n) .ne. 0)
+     $                dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $                    + weights(1,n) * src_array(src_addr(n))
+     $                    + weights(2,n) * gradient_lat(src_addr(n))
+     $                    + weights(3,n) * gradient_lon(src_addr(n))
+               ENDDO
+               DEALLOCATE(gradient_lat, gradient_lon)
+C
+           END SELECT           ! order
+C
+       CASE ('BILINEAR')        ! bilinear remapping 
+C
+           DO n = 1, num_links
+             IF (src_addr(n) .ne. 0)
+     $           dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $              + weights(1,n) * src_array(src_addr(n))
+           ENDDO
+C
+       CASE ('BICUBIC')         ! bicubic remapping
+C
+           SELECT CASE (cdgrdtyp) !
+           CASE ('LR')          ! logically rectangular
+
+               ALLOCATE(gradient_i(src_size), gradient_j(src_size),
+     $             gradient_ij(src_size))
+C
+               CALL gradient_bicubic(nlon_src,nlat_src,src_array,
+     $             sou_mask, src_lat, src_lon, id_nosper,
+     $             gradient_i, gradient_j, gradient_ij)
+C
+               DO n = 1, num_links
+                 IF (src_addr(n) .ne. 0)
+     $            dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $               + weights(1,n) * src_array(src_addr(n))
+     $               + weights(2,n) * gradient_i(src_addr(n))
+     $               + weights(3,n) * gradient_j(src_addr(n))
+     $               + weights(4,n) * gradient_ij(src_addr(n))
+               ENDDO
+C
+               DEALLOCATE(gradient_i, gradient_j, gradient_ij)
+C
+           CASE ('D')           !reduced
+C
+               DO n = 1, num_links
+                 IF (src_addr(n) .ne. 0)
+     $            dst_array(dst_addr(n)) =  dst_array(dst_addr(n))
+     $               + weights(1,n) * src_array(src_addr(n))
+               ENDDO
+C
+           END SELECT
+C
+       CASE ('DISTWGT')         ! distance weighted average
+C
+           DO n = 1, num_links
+             IF (src_addr(n) .ne. 0)
+     $        dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $              + weights(1,n) * src_array(src_addr(n))
+           ENDDO
+C
+      CASE ('GAUSWGT')          ! distance gaussian weighted average
+C
+          DO n = 1, num_links
+            IF (src_addr(n) .ne. 0)
+     $       dst_array(dst_addr(n)) = dst_array(dst_addr(n))
+     $              + weights(1,n) * src_array(src_addr(n))
+          ENDDO
+C
+      END SELECT                ! remapping method
+C
+C*    5. Check the cells on the poles
+C        ----------------------------
+C
+C* -- For the north pole _N and the south pole _S
+C
+      latpol_N = pi*half
+      latpol_S = -pi*half
+      compt_N = 0
+      moy_tmp_N = 0d0
+      moy_ERR_N = 0d0
+      compt_S = 0
+      moy_tmp_S = 0d0
+      moy_ERR_S = 0d0
+C
+      DO n = 1, dst_size
+        IF (dst_lat(n) == latpol_N) THEN
+            moy_tmp_N = moy_tmp_N + dst_array(n)
+            moy_err_N = moy_err_N + dst_err(n)
+            compt_N = compt_N + 1
+        ELSE IF (dst_lat(n) == latpol_S) THEN
+            moy_tmp_S = moy_tmp_S + dst_array(n)
+            moy_err_S = moy_err_S + dst_err(n)
+            compt_S = compt_S + 1
+        END IF
+      END DO
+C
+      IF (compt_N/=0) THEN
+          moy_tmp_N = moy_tmp_N/compt_N
+          moy_err_N = moy_err_N/compt_N
+          DO n = 1, num_links
+            IF (dst_lat(dst_addr(n)) == latpol_N) THEN
+                dst_array(dst_addr(n)) = moy_tmp_N
+                dst_err(dst_addr(n)) = moy_err_N
+            END IF
+          END DO
+          PRINT*, 'Points at the pole N'
+          PRINT*, 'Average value at the pole : ', moy_tmp_N
+          PRINT*, 'Average error at the pole : ', moy_err_N
+      ELSE
+          PRINT*, 'No point at the pole N'
+      END IF
+C
+      IF (compt_S/=0) THEN
+          moy_tmp_S = moy_tmp_S/compt_S
+          moy_err_S = moy_err_S/compt_S
+          DO n = 1, num_links
+            IF (dst_lat(dst_addr(n)) == latpol_S) THEN
+                dst_array(dst_addr(n)) = moy_tmp_S
+                dst_err(dst_addr(n)) = moy_err_S
+            END IF
+          END DO
+          PRINT*, 'Points at the pole S'
+          PRINT*, 'Average value at the pole : ', moy_tmp_S
+          PRINT*, 'Average error at the pole : ', moy_err_S
+      ELSE
+          PRINT*, 'No point at the pole S'
+      END IF
+C
+      DEALLOCATE (src_addr, dst_addr, weights)
+C
+C*    6. Close remapping file
+C        --------------------
+C
+      CALL hdlerr(NF_CLOSE(nc_scpid), 'scriprmp')
+C
+C*    7. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine scriprmp ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/lib/scrip/src/scriprmp_vector.F90
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/scriprmp_vector.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/scriprmp_vector.F90	(revision 1677)
@@ -0,0 +1,1213 @@
+SUBROUTINE scriprmp_vector( &
+     dst_array,   src_array,       src_size,    dst_size,      src_mask, &
+     dst_mask,    src_lon,         src_lat,     nlon_src,      nlat_src, &
+     dst_lon,     dst_lat,         nlon_dst,    nlat_dst,      map_method, &
+     cdgrdtyp,    id_nosper,       src_name,    dst_name,      normalize_opt, &
+     order,       rst_type,        n_srch_bins, lextrapdone,   rl_varmul, &
+     id_scripvoi, src_array_assoc, cfldtype,    src_lon_assoc, src_lat_assoc, &
+     src_mask_assoc, src_name_assoc, dst_name_assoc,lrotate, dst_array_assoc, &
+     src_size_assoc, dst_size_assoc, nlon_src_assoc, nlat_src_assoc)
+
+
+! Input:
+!C     -----
+!C             src_array : field on source grid(real 1D)
+!C             src_size  : source grid size (integer)
+!C             dst_size  : target grid size (integer)
+!C             src_mask  : source grid mask (INTEGER)
+!C             dst_mask  : target grid mask (INTEGER)
+!C             src_lon   : source grid longitudes (real 1D)
+!C             src_lat   : source grid latitudes (real 1D)
+!C             nlon_src  : number of source grid longitudes (integer)
+!C             nlat_src  : number of source grid latitudes (integer)
+!C             dst_lon   : target grid longitudes (real 1D)
+!C             dst_lat   : target grid latitudes (real 1D)
+!C             nlon_dst  : number of destination grid longitudes (integer)
+!C             nlat_dst  : number of destination grid latitudes (integer)
+!C             map_method: remapping method (character*8)
+!C             cdgrdtyp  : source grid type (character*8)
+!C             id_nosper : number of overlapping for source grid
+!C             src_name  : source grid name (character*8)
+!C             dst_name  : target grid name (character*8)
+!C             normalize_opt: option for normalization (character*8)
+!C             order        : order of conservative remapping (character*8)
+!C             rst_type     : type of scrip search restriction (character*8)
+!C             n_srch_bins  : number of seach bins (integer)
+!C             lextrapdone  : logical, true if EXTRAP done on field
+!C             rl_varmul    : Gaussian variance (for GAUSWGT)
+!C             id_scripvoi  : number of neighbour for DISTWGT and GAUSWGT
+!C             src_name_assoc  : source grid name for the associated vector
+!C             src_array_assoc : field on source grid for associated composant
+!C             cfldtype       : 'VECTOR_I' or 'VECTOR_J'
+!C             src_lon_assoc  : source grid longitudes for associated field
+!C             src_lat_assoc  : source grid latitudes for associated field
+!C             src_mask_assoc : source grid mask (INTEGER) for associated field
+!C             src_name_assoc : source grid name for associated field
+!C             dst_name_assoc : target grid name for associated field
+!C             lrotate : logical to do or not rotation to cartesian 
+!C             src_size_assoc : source grid size associated(integer)
+!C             dst_size_assoc : target grid size associated(integer)
+!C             nlon_src_assoc : number of source grid associated longitudes (integer)
+!C             nlat_src_assoc : number of source grid associated latitudes (integer)
+!C
+!C     Output:
+!C     ------
+!C             dst_array : field on target grid (real 1D)
+!C             dst_array_assoc : associated field on target grid (real 1D)
+!C
+!C     Externals:
+!C     ---------
+!C     corners, scrip, gradient, gradient_bilin
+!C
+!C 
+!C     History:
+!C     --------
+!C     E. Rapaport     2004/03     Created
+
+!C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!C* ---------------------------- Modules used ----------------------------
+  USE grids
+  USE rotations
+!
+!* ---------------------------- Implicit --------------------------------
+!
+  IMPLICIT NONE
+!
+!* ---------------------------- Include files ---------------------------
+!
+!* ---------------------------- Intent In -------------------------------
+!
+  INTEGER(KIND=int_kind), INTENT(in) :: &
+       nlon_src, &           ! number of source grid longitudes
+       nlat_src, &           ! number of source grid latitudes
+       nlon_src_assoc,&      ! number of source grid associated longitudes
+       nlat_src_assoc,&      ! number of source grid associated latitudes
+       nlon_dst, &           ! number of destination grid longitudes
+       nlat_dst, &           ! number of destination grid latitudes
+       src_size, &           ! number of source grid cells
+       dst_size, &           ! number of destination grid cells
+       src_size_assoc, &     ! number of source grid cells associated
+       dst_size_assoc, &     ! number of destination grid cells associated
+       n_srch_bins, &        ! number of search bins fos SCRIP
+       src_mask(src_size), & ! source grid mask
+       dst_mask(dst_size), & ! target grid mask
+       id_nosper, &          ! number of overlapping points for source grid
+       src_mask_assoc(src_size)     ! source grid mask for associated field
+
+  REAL (KIND=real_kind), INTENT(in) :: &
+       src_array(src_size),&       ! source grid array
+       src_array_assoc(src_size),& ! source grid array for associated vector 
+                                   ! composant
+       src_lon(src_size), &        ! source grid longitudes
+       src_lat(src_size), &        ! source grid latitudes
+       dst_lon(dst_size), &        ! target grid longitudes
+       dst_lat(dst_size),&         ! target grid latitudes
+       src_lon_assoc(src_size_assoc), &  ! source grid longitudes and latitudes for 
+       src_lat_assoc(src_size_assoc)     ! associated vector composant 
+
+  CHARACTER(LEN=8), INTENT(in) :: &
+       map_method, &         ! remapping method
+       cdgrdtyp,  &          ! source grid type
+       src_name,  &          ! source grid name
+       src_name_assoc, &     ! source grid name for assoc composant
+       dst_name,  &          ! target grid name
+       dst_name_assoc, &     ! target grid name for assoc composant
+!       normalize_opt, &      ! option for normalization
+       order, &              ! order of conservative remapping
+       rst_type, &           ! type of scrip search restriction
+       cfldtype              ! 'VECTOR_I' or 'VECTOR_J'
+
+  CHARACTER(LEN=8) :: normalize_opt
+            
+  LOGICAL, INTENT(in) :: &
+       lextrapdone          ! logical, true if EXTRAP done on field
+
+  REAL (KIND=real_kind), INTENT(in) :: &
+       rl_varmul            ! Gaussian variance (for GAUSWGT)
+
+  INTEGER(KIND=int_kind), INTENT(in) :: &
+       id_scripvoi          ! number of neighbour for DISTWGT and GAUSWGT
+
+  LOGICAL :: lrotate        ! to do or not rotation to cartesien
+!
+!* ---------------------------- Intent Out -------------------------------
+!
+  REAL (KIND=real_kind), INTENT(out):: &
+       dst_array(dst_size),&       ! field array on destination grid
+       dst_array_assoc(dst_size)   !associated field interpolated
+!
+!* ---------------------------- Local declarations ----------------------
+!
+  REAL (KIND=real_kind), DIMENSION(dst_size):: &
+       dst_array_k
+
+  REAL (KIND=real_kind), DIMENSION(src_size,2,2) :: &
+       trans1
+
+  REAL (KIND=real_kind), DIMENSION(src_size,3,2) :: &
+       trans_loc2car, trans2
+
+  REAL (KIND=real_kind), DIMENSION(dst_size,3,3) :: &
+       trans3, trans4, trans_car2loc
+
+  REAL (KIND=real_kind), DIMENSION(:), ALLOCATABLE ::  src_interp
+  
+  REAL (KIND=real_kind):: &
+       src_comp_ij(src_size,2), &    ! source arrays perhaps in differnet points
+       src_comp_xyz(src_size,3), &   ! source arrays in the same points
+       dst_comp_xyz(dst_size,3), &
+       dst_comp_ij(dst_size,2)
+
+  CHARACTER(LEN=12) :: &
+       cweight, &            ! string for weights
+       nom_angle             !name to test if information about angle 
+                             !are done in grids.nc 
+
+  CHARACTER(LEN=11) :: &
+       csrcadd, &            ! string for source grid addresses
+       cdstadd               ! string for destination grid addresses
+  
+  CHARACTER(LEN=13) :: &
+       cdstare, &            ! string for destination grid area
+       cdstfra               ! string for destination grid frac
+
+  CHARACTER (char_len) :: &
+       cmapping, &           ! mapping name
+       cmapping_inter, &     ! mapping name between 2 source grids
+       crmpfile, &           ! name of the SCRIP matrix file
+       crmpfile_inter        ! name of the SCRIP matrix file, between 2 src grids
+    
+  INTEGER (KIND=int_kind) :: &
+       n, &                  ! looping indice
+       num_links, &          ! number of intersections
+       ncrn, &               ! number of grid cell corners
+       src_rank, dst_rank, & ! source / target grid rank
+       num_wgts, &           ! number of weights
+       src_dims(2), &        ! source grid dimensions
+       dst_dims(2), &        ! target grid dimensions
+       sou_mask(src_size),&  
+       tgt_mask(dst_size)    ! target grid mask
+
+  REAL (KIND=real_kind) :: &
+       dst_area(dst_size), & ! target grid area
+       dst_frac(dst_size), & ! target grid frac
+       dst_err(dst_size), &  ! target grid error
+       src_area(src_size), src_frac(src_size)
+
+!    netCDF-declarations
+  INTEGER(KIND=int_kind) :: &
+       stat, stat1, stat2, &  ! netCDF error status
+       dimid1, &               ! dimension id
+       varid, &               ! variable id
+       nc_fileid, &
+       dimid_src, dimid_dst, &
+       dimid_2, dimid_3, id_loc2car, id_car2loc, &       
+       nc_gridsid, anglid, &        
+       trans1id, trans2id, &
+       id_dim(3)
+
+  LOGICAL :: &
+       lcalc_interp, lcalc_rotate            ! calculate matrix?
+
+  INTEGER(KIND=int_kind), DIMENSION(:), ALLOCATABLE :: &
+       src_addr, &           ! addresses of source grid 
+       dst_addr              ! addresses of destination grid
+
+  REAL (KIND=real_kind), DIMENSION(:), ALLOCATABLE :: &
+       gradient_lat, &       ! latitudinal gradient (conservative rmp.)
+       gradient_lon, &       ! longitudinal gradient (conservative rmp.)
+       gradient_i, &         ! gradient in i direction (bilinear rmp.)
+       gradient_j, &         ! gradient in j direction (bilinear rmp.)
+       gradient_ij           ! cross gradient (bilinear rmp.)
+
+  REAL (KIND=real_kind), DIMENSION (:,:), ALLOCATABLE :: &
+       weights               ! Remapping weights
+
+  REAL (KIND=real_kind), DIMENSION (:,:), ALLOCATABLE :: &
+       dst_corner_lon, &     ! longitudes of destination grid corners
+       dst_corner_lat, &     ! latitudes of destination grid corners
+       src_pt2_corner_lon, & ! longitudes of source grid corners
+       src_pt2_corner_lat    ! latitudes of source grid corners
+
+!    pole contribution
+  REAL (KIND=real_kind) :: &
+       moy_tmp_S, moy_tmp_N,& ! field average at the pole
+       moy_err_S, moy_err_N,&   ! error average at the pole
+       latpol_N,latpol_S
+
+  INTEGER(KIND=int_kind) :: &
+       compt_S, compt_N, &    ! number of cells representating a pole
+       icount, jcount, ptpr         
+
+  INTEGER :: k, ib, kcount, ilenstr, icomp
+
+  LOGICAL :: ll_src_spheric, ll_dst_spheric, &  ! flag for spheric grid
+       testk, lfracnnei  
+                                  
+!k-component
+  INTEGER(KIND=int_kind) :: &
+       nc_testfileid, id_kcomp, dimid_kcomp(2), &
+       dimid_lon,dimid_lat, dim1, dim2,dimid_test(2),&
+       id_lon, id_lat
+
+  CHARACTER(char_len) :: namelon, namelat, namefile
+
+  REAL (KIND=real_kind), DIMENSION(dst_size):: &
+       k_error
+
+  REAL(KIND=real_kind) :: &
+       moy_k_error, max_k_error, &  !average, max, standard deviation 
+       temp , var_k_error           !of k-component error
+
+!same grids
+  LOGICAL :: &
+       ll_same_dst_grids    ! true if target grids are the same
+ 
+  CHARACTER(LEN=8) :: &
+       src_name1, src_name2
+
+  INTEGER(KIND=int_kind) :: &
+       src_size1, src_size2, &
+       nlon_src1, nlat_src1, &
+       nlon_src2, nlat_src2
+
+  INTEGER(KIND=int_kind),DIMENSION(:),ALLOCATABLE :: &
+       src_mask1, src_mask2
+
+  REAL(KIND=real_kind),DIMENSION(:),ALLOCATABLE :: &
+       src_array_inter, dst_array_inter,&
+       src_array2, src_array1, &
+       src_lon1, src_lat1, &
+       src_lon2, src_lat2
+
+!fichiers resultats projection
+  INTEGER(KIND=int_kind) :: &
+       nc_projectionid, id_jpio, id_jpjo, dimid(2), &
+       comp1_sphid, comp2_sphid, comp1_carid, comp2_carid,&
+       comp3_carid
+
+
+!* ---------------------------- Poema verses ----------------------------
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Initialization
+!        --------------
+  IF (nlogprt .GE. 2) THEN
+     WRITE (UNIT = nulou,FMT = *) ' '
+     WRITE (UNIT = nulou,FMT = *) &
+          '           ROUTINE scriprmp_vector  -  Level 3'
+     WRITE (UNIT = nulou,FMT = *) &
+          '           ***********************     *******'
+     WRITE (UNIT = nulou,FMT = *) ' '
+     WRITE (UNIT = nulou,FMT = *) 'SCRIP remapping for vector'
+     WRITE (UNIT = nulou,FMT = *) ' '
+  ENDIF
+
+  IF (nlogprt .GE. 2) THEN
+     WRITE (UNIT = nulou,FMT = *) 'source grid name :', src_name
+     WRITE (UNIT = nulou,FMT = *) &
+       'source grid name assoc :', src_name_assoc
+     WRITE (UNIT = nulou,FMT = *) 'target grid name :', dst_name
+     WRITE (UNIT = nulou,FMT = *) &
+          'target grid name assoc:', dst_name_assoc
+     CALL FLUSH (nulou)
+  ENDIF
+!*
+!* -- If target grids are the same and component J is being treated, 
+!* -- no computation is needeed.
+!
+  IF(dst_name .eq. dst_name_assoc) THEN
+     ll_same_dst_grids = .TRUE.
+  ELSE
+     ll_same_dst_grids = .FALSE.
+  END IF
+
+  IF(ll_same_dst_grids .AND. cfldtype == 'VECTOR_J') THEN
+      WRITE (UNIT = nulou,FMT = *) &
+         '         Same target grid    ' 
+      WRITE (UNIT = nulou,FMT = *) &
+         'the second composant has already been computed'
+  ELSE
+
+!
+!* -- If source grids are the same, interpolation from one to the other is done
+!
+
+  IF(src_name >= src_name_assoc) THEN  !interpolation from src_grid to src_grid_assoc
+     src_name1 = src_name
+     src_name2 = src_name_assoc
+     src_size1 = src_size
+     src_size2 = src_size_assoc
+     nlon_src1 = nlon_src
+     nlat_src1 = nlat_src
+     nlon_src2 = nlon_src_assoc
+     nlat_src2 = nlat_src_assoc
+  ELSE                                !interpolation from src_grid_asso to src_grid
+     src_name1 = src_name_assoc
+     src_name2 = src_name
+     src_size1 = src_size_assoc
+     src_size2 = src_size
+     nlon_src1 = nlon_src_assoc
+     nlat_src1 = nlat_src_assoc
+     nlon_src2 = nlon_src
+     nlat_src2 = nlat_src
+  END IF
+
+  ALLOCATE(src_array1(src_size2))
+  ALLOCATE(src_array2(src_size2))
+  ALLOCATE(dst_array_inter(src_size2))
+  ALLOCATE(src_array_inter(src_size1))
+  ALLOCATE(src_mask1(src_size1))
+  ALLOCATE(src_mask2(src_size2))
+  ALLOCATE(src_lon1(src_size1))
+  ALLOCATE(src_lat1(src_size1))
+  ALLOCATE(src_lon2(src_size2))
+  ALLOCATE(src_lat2(src_size2))
+
+  IF(src_name >= src_name_assoc) THEN  !interpolation from src_grid to src_grid_assoc
+     src_array_inter = src_array
+     src_mask1 = src_mask
+     src_mask2 = src_mask_assoc
+     src_lon1 = src_lon
+     src_lat1 = src_lat
+     src_lon2 = src_lon_assoc
+     src_lat2 = src_lat_assoc
+  ELSE                                !interpolation from src_grid_assoc to src_grid
+     src_array_inter = src_array_assoc
+     src_mask1 = src_mask_assoc
+     src_mask2 = src_mask
+     src_lon1 = src_lon_assoc
+     src_lat1 = src_lat_assoc
+     src_lon2 = src_lon
+     src_lat2 = src_lat
+  END IF
+
+  IF(src_name .NE. src_name_assoc) THEN
+     CALL scriprmp( &
+          dst_array_inter, src_array_inter, src_size1, src_size2, &
+          src_mask1, src_mask2, src_lon1, src_lat1, &
+          nlon_src1, nlat_src1, src_lon2,&
+          src_lat2, nlon_src2, nlat_src2,map_method, &
+          cdgrdtyp, id_nosper, src_name1, src_name2, normalize_opt, &
+          order, rst_type, n_srch_bins, lextrapdone, rl_varmul, &
+          id_scripvoi)
+ END IF
+
+     IF(src_name > src_name_assoc) THEN     !interpolation from src_grid to src_grid_assoc
+        src_array1 = dst_array_inter
+        src_array2 = src_array_assoc
+     ELSEIF(src_name < src_name_assoc) THEN !interpolation from src_grid_asso to src_grid
+        src_array1 = src_array
+        src_array2 = dst_array_inter
+     ELSE                                   !same source grids, no interpolation
+        src_array1 = src_array
+        src_array2 = src_array_assoc
+     END IF
+
+     DEALLOCATE(dst_array_inter,src_array_inter)
+!
+!* -- Get the name of the files containing the remapping matrix.
+!  
+  icount = ilenstr(src_name2,jpeight)
+  kcount = ilenstr(dst_name,jpeight)
+
+  SELECT CASE (map_method)
+  CASE ('CONSERV')          ! conservative remapping
+     cmapping = &
+          src_name2(1:icount)//' to '//dst_name(1:kcount)//' '&
+          //map_method//' '//normalize_opt(1:4)//' remapping'
+      
+     crmpfile = &
+          'rmp_'//src_name2(1:icount)//'_to_'//dst_name(1:kcount)&
+          //'_'//map_method(1:7)//'_'//normalize_opt(1:4)//'.nc'     
+        
+  CASE DEFAULT
+     cmapping = &
+          src_name2(1:icount)//' to '//dst_name(1:kcount)//' '&
+          //map_method//' remapping'
+      
+     crmpfile = &
+          'rmp_'//src_name2(1:icount)//'_to_'//dst_name(1:kcount)&
+          //'_'//map_method(1:7)//'.nc'
+  END SELECT
+
+  IF (nlogprt .GE. 2) THEN
+     WRITE (UNIT = nulou,FMT = *) &
+          ' SCRIP filename : ', crmpfile
+     CALL FLUSH(nulou)
+  ENDIF
+!
+!* -- find out whether remapping file exists
+!              
+  stat = NF_OPEN(crmpfile, NF_WRITE, nc_fileid) 
+  IF (stat == NF_NOERR) THEN 
+     lcalc_interp = .FALSE.
+     IF (nlogprt .GE. 2) THEN
+        WRITE (UNIT = nulou,FMT = *) &
+             'SCRIP file opened - no matrix calculation needed' 
+        WRITE (UNIT = nulou,FMT = *) ' '
+        CALL FLUSH(nulou)
+     ENDIF
+!
+!* fint out if rotation matrix exist in this file
+!
+     stat1 = NF_INQ_VARID &
+          (nc_fileid, 'trans_loc2car', trans1id)
+     stat2 = NF_INQ_VARID &
+          (nc_fileid, 'trans_car2loc', trans2id)     
+     IF (stat1 == NF_NOERR .and. &
+          stat2 == NF_NOERR) THEN 
+        lcalc_rotate = .FALSE.
+     ELSE
+        lcalc_rotate = .TRUE.
+        IF (nlogprt .GE. 2) THEN
+           WRITE (UNIT = nulou,FMT = *) &
+                'Only rotation matrix calculation is needed' 
+           WRITE (UNIT = nulou,FMT = *) ' '
+           CALL FLUSH(nulou)
+        END IF
+     ENDIF
+
+  ELSE
+     lcalc_interp = .true.
+     lcalc_rotate = .true.
+  END IF  
+
+  IF(.not. lrotate) lcalc_rotate = .false.
+
+  IF (nlogprt .GE. 2) THEN
+     IF(lrotate) THEN
+          WRITE(UNIT=nulou,FMT=*) &
+               'rotation to the cartesien has been asked'
+          WRITE(UNIT=nulou,FMT=*) ' '
+          CALL FLUSH(nulou)
+       END IF
+  END IF
+
+!
+!* -- character strings of weights and addresses
+!
+  csrcadd = 'src_address'
+  cdstadd = 'dst_address'
+  cweight = 'remap_matrix'
+  cdstare = 'dst_grid_area'
+  cdstfra = 'dst_grid_frac'
+
+!
+!*    2. Computing for interpolation between source and target grids 
+!        -----------------------------------------------------------
+!        -----------------------------------------------------------
+!  
+!* -- setting of the mask for the source AND the target grid
+!       
+  WHERE (src_mask2 .eq. 1)
+     sou_mask = 0
+  END WHERE
+  WHERE (src_mask2 .eq. 0)
+     sou_mask = 1
+  END WHERE
+
+  WHERE (dst_mask .eq. 1)
+     tgt_mask = 0
+  END WHERE
+  WHERE (dst_mask .eq. 0)
+     tgt_mask = 1
+  END WHERE
+
+
+  IF (lcalc_interp) THEN 
+!
+!*    2.1. Calculate SCRIP remapping matrix : source to destination grid
+!          -------------------------------------------------------------
+     SELECT CASE (normalize_opt)
+     CASE ('FRACNNEI')
+        normalize_opt = 'FRACAREA'
+        lfracnnei = .true.
+     END SELECT
+
+     IF (nlogprt .GE. 2) THEN 
+        WRITE (UNIT = nulou,FMT = *) & 
+             ' Calculation of SCRIP remapping matrix: method = ', &
+             map_method
+        WRITE (UNIT = nulou,FMT = *) ' '
+     ENDIF
+!
+!*    -- get grid cell corners for conservative remapping
+!
+     ncrn = 4.
+
+     IF (map_method == 'CONSERV') THEN	  
+        ALLOCATE(src_pt2_corner_lon(ncrn,src_size2), &
+	     src_pt2_corner_lat(ncrn,src_size2),&
+	     dst_corner_lon(ncrn,dst_size),&
+	     dst_corner_lat(ncrn,dst_size))
+
+        CALL corners(nlon_src2, nlat_src2, ncrn, src_lon2, &
+	     src_lat2, src_name2, cdgrdtyp, src_pt2_corner_lon, &
+	     src_pt2_corner_lat)
+        CALL corners(nlon_dst, nlat_dst, ncrn, dst_lon, dst_lat,&
+	     dst_name, cdgrdtyp, dst_corner_lon, dst_corner_lat)
+     ENDIF
+!
+!*    -- initialization of grid arrays for SCRIP
+!
+     src_dims(1) = nlon_src2
+     src_dims(2) = nlat_src2
+     dst_dims(1) = nlon_dst
+     dst_dims(2) = nlat_dst
+     src_rank    = 2
+     dst_rank    = 2
+
+     CALL grid_init(map_method, rst_type, n_srch_bins,&
+          src_size2, dst_size, src_dims, dst_dims,&
+          src_rank, dst_rank, ncrn, ncrn,&
+          sou_mask, tgt_mask, src_name2, dst_name,&
+          src_lat2, src_lon2, dst_lat, dst_lon,&
+          src_pt2_corner_lat, src_pt2_corner_lon,&
+          dst_corner_lat, dst_corner_lon)
+!
+!*    -- calculation of weights and addresses using SCRIP-library
+!
+     CALL scrip(crmpfile, cmapping, map_method, normalize_opt, &
+          lextrapdone, rl_varmul, id_scripvoi)
+
+     IF (map_method == 'CONSERV') THEN
+        DEALLOCATE(src_pt2_corner_lon, src_pt2_corner_lat,&
+	     dst_corner_lon, dst_corner_lat)
+     ENDIF
+
+  END IF  !lcalc_interp
+
+!
+!*    2.2. Calculate rotation matrix
+!          -------------------------
+!* -rotation local/spheric referentials 
+!first, source grid
+!
+  CALL hdlerr(NF_OPEN &
+       ('grids.nc',NF_NOWRITE, nc_gridsid), 'scriprmp_vector')
+
+  nom_angle = src_name2(1:icount)//'.ang'
+
+  stat = NF_INQ_VARID(nc_gridsid, nom_angle, anglid)
+     
+  IF(stat == NF_NOERR) THEN
+     ll_src_spheric = .false.
+  ELSE
+     ll_src_spheric = .true.
+     WRITE (UNIT = nulou,FMT = *) &
+          '    WARNING'
+     WRITE (UNIT = nulou,FMT = *) &
+          '***************'
+     WRITE (UNIT = nulou,FMT = *) &
+          'file grids.nc contains no angle information'
+     WRITE (UNIT = nulou,FMT = *) &
+          'source grid '// src_name// &
+          ' will be considered as a spheric referential'
+     CALL FLUSH(nulou)
+  END IF
+!
+!Target grid
+!
+  nom_angle = dst_name(1:kcount)//'.ang' 
+
+  stat = NF_INQ_VARID(nc_gridsid, nom_angle, anglid)
+
+  IF(stat == NF_NOERR) THEN
+     ll_dst_spheric = .false.
+  ELSE
+     ll_dst_spheric = .true.
+     WRITE (UNIT = nulou,FMT = *) &
+          '    WARNING'
+     WRITE (UNIT = nulou,FMT = *) &
+          '***************'
+     WRITE (UNIT = nulou,FMT = *) &
+          'file grids.nc contains no angle information'
+     WRITE (UNIT = nulou,FMT = *) &
+          'target grid '//dst_name// &
+          ' will be considered as a spheric referential'
+     CALL FLUSH(nulou)
+  END IF
+
+  CALL hdlerr(NF_CLOSE(nc_gridsid), 'scriprmp_vector')
+!
+!*Compute necessary rotaion matrix between local and spheric referentials
+!
+  IF(.NOT. ll_src_spheric) &
+       CALL loc2spher(src_name2, src_size2, trans1)
+        
+  IF(.NOT. ll_dst_spheric) & 
+       CALL spher2loc(dst_name, dst_size,trans4) 
+
+  IF(lcalc_rotate) THEN 
+! 
+!* - calculate matrix for rotation from spheric to Cartesian referentials
+!
+     CALL spher2car(src_lon2, src_lat2, src_size2, trans2)
+     
+     IF (.NOT. ll_src_spheric) THEN
+        DO n=1,src_size2
+           trans_loc2car(n,1:3,1:2) = &
+                MATMUL(trans2(n,1:3,1:2),trans1(n,1:2,1:2))
+        ENDDO
+     ELSE
+        trans_loc2car(:,:,:) = trans2(:,:,:)
+     END IF
+!
+!* - calculate matrix for rotation from Cartesian to spheric referentials
+!   
+     CALL car2spher(dst_lon, dst_lat, dst_size, trans3)
+
+     IF (.NOT. ll_dst_spheric) THEN
+        DO n=1, dst_size
+           trans_car2loc(n,1:3,1:3) = &
+                MATMUL(trans4(n,1:3,1:3),trans3(n,1:3,1:3))
+        ENDDO
+     ELSE
+        trans_car2loc(:,:,:) = trans3(:,:,:)
+     END IF
+!
+!*   2.4. Save in file, already created, transformations loc2car and car2loc
+!         ------------------------------------------------------------------
+!* -  creation, definition and initialization of netcdf variables 
+!     in file crmpfile
+!
+      CALL hdlerr(NF_OPEN &
+	 (crmpfile, NF_WRITE, nc_fileid), 'scriprmp_vector')
+
+      CALL hdlerr(NF_REDEF(nc_fileid), 'scriprmp_vector')
+
+      CALL hdlerr(NF_INQ_DIMID &
+	 (nc_fileid,'src_grid_size',dimid_src), 'scriprmp_vector')
+
+      CALL hdlerr(NF_INQ_DIMID &
+	 (nc_fileid,'dst_grid_size',dimid_dst), 'scriprmp_vector')
+
+      CALL hdlerr(NF_DEF_DIM &
+	 (nc_fileid,'dim_2',2,dimid_2), 'scriprmp_vector')
+
+      CALL hdlerr(NF_DEF_DIM &
+	 (nc_fileid,'dim_3',3,dimid_3), 'scriprmp_vector')
+
+      id_dim(1) = dimid_src 
+      id_dim(2) = dimid_3
+      id_dim(3) = dimid_2
+
+      CALL hdlerr(NF_DEF_VAR &
+	 (nc_fileid,'trans_loc2car',NF_DOUBLE,3,id_dim,&
+	 id_loc2car), 'scriprmp_vector')     
+
+      CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,id_loc2car, 'matrix',&
+	 LEN_TRIM('local to Cartesian'),'local to Cartesian'),&
+	 'scriprmp_vector')
+
+      id_dim(1) = dimid_dst
+      id_dim(2) = dimid_3
+      id_dim(3) = dimid_3
+
+      CALL hdlerr(NF_DEF_VAR &
+	 (nc_fileid,'trans_car2loc',NF_DOUBLE,3,id_dim,&
+	 id_car2loc), 'scriprmp_vector')
+
+      CALL hdlerr(NF_PUT_ATT_TEXT(nc_fileid,id_car2loc, 'matrix',&
+	 LEN_TRIM('Cartesian to local'),'Cartesian to local'),'scriprmp_vector')
+
+      CALL hdlerr(NF_ENDDEF(nc_fileid), 'scriprmp_vector')
+
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+	 (nc_fileid,id_loc2car,trans_loc2car),'scriprmp_vector')
+
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+	 (nc_fileid,id_car2loc,trans_car2loc),'scriprmp_vector')
+
+      CALL hdlerr(NF_CLOSE(nc_fileid),'scriprmp_vector')
+
+   END IF   !lcalc_rotate
+!
+!*    -- open just created SCRIP matrix file crmpfile
+!         
+      CALL hdlerr(NF_OPEN(crmpfile, NF_NOWRITE, nc_fileid), 'scriprmp_vector')
+
+      IF (nlogprt .GE. 2) THEN
+	  WRITE (UNIT = nulou,FMT = *) &
+	     ' SCRIP file ',crmpfile,' created and opened' 
+	  WRITE (UNIT = nulou,FMT = *) ' '
+	  CALL FLUSH(nulou)
+      ENDIF
+!
+!* -- End of transformation and weight calculation
+!     --------------------------------------------
+!     --------------------------------------------
+
+!
+!*    3. Read weights and addresses
+!        --------------------------
+!        --------------------------
+!* -- get number of weights
+!
+  SELECT CASE (map_method)
+  CASE ('CONSERV')          ! conservative remapping
+      num_wgts = 3.
+  CASE ('BILINEAR')         ! bilinear remapping
+      num_wgts = 1.
+  CASE ('BICUBIC')          ! bicubic remapping   
+      IF (cdgrdtyp .eq. 'LR') THEN ! logically rectangular
+	  num_wgts = 4.
+      ELSE                  ! reduced  
+	  num_wgts=1.
+      ENDIF
+  CASE ('DISTWGT')          ! distance weighted averaging
+      num_wgts = 1.
+  CASE ('GAUSWGT')          ! distance gaussian weighted averaging
+      num_wgts = 1.
+  END SELECT
+
+!
+!*    4. Do interpolation between source and target grids
+!        ------------------------------------------------
+!        ------------------------------------------------
+  IF(lrotate) THEN
+!
+!* -- find composant i and j
+!
+     IF (cfldtype == 'VECTOR_I') THEN
+        src_comp_ij(:,1) = src_array1(:)
+        src_comp_ij(:,2) = src_array2(:)
+     ELSE
+        src_comp_ij(:,1) = src_array2(:)
+        src_comp_ij(:,2) = src_array1(:)
+     END IF
+!
+!*   4.1.Read and do the transformation from local to Cartesian referentials
+!        -------------------------------------------------------------------
+     CALL hdlerr(NF_INQ_VARID &
+          (nc_fileid, 'trans_loc2car',id_loc2car), 'scriprmp_vector')
+  
+     CALL hdlerr(NF_GET_VAR_DOUBLE &
+          (nc_fileid, id_loc2car, trans_loc2car), 'scriprmp_vector')
+ 
+     src_comp_xyz(:,:) = 0.
+     DO ib=1,3
+        src_comp_xyz(:,ib) = &
+             trans_loc2car(:,ib,1) * src_comp_ij(:,1) + &
+             trans_loc2car(:,ib,2) * src_comp_ij(:,2)             
+     ENDDO
+     icomp = 3.
+
+#ifdef __DEBUG     
+     CALL hdlerr(NF_CREATE &
+          ('projection.nc',0,nc_projectionid),'scriprmp_vector')
+
+     CALL hdlerr(NF_DEF_DIM&
+          (nc_projectionid, 'jpio', 182, id_jpio),'scriprmp_vector')
+     CALL hdlerr(NF_DEF_DIM&
+          (nc_projectionid, 'jpjo', 149, id_jpjo),'scriprmp_vector')
+
+     dimid(1) = id_jpio ; dimid(2) = id_jpjo
+
+     CALL hdlerr(NF_DEF_VAR &
+          (nc_projectionid, 'comp1_sph', NF_DOUBLE,2, dimid, &
+          comp1_sphid),'scriprmp_vector')
+     CALL hdlerr(NF_DEF_VAR &
+          (nc_projectionid, 'comp2_sph', NF_DOUBLE,2, dimid, &
+          comp2_sphid),'scriprmp_vector')
+      CALL hdlerr(NF_DEF_VAR &
+          (nc_projectionid, 'comp1_car', NF_DOUBLE,2, dimid, &
+          comp1_carid),'scriprmp_vector')
+      CALL hdlerr(NF_DEF_VAR &
+          (nc_projectionid, 'comp2_car', NF_DOUBLE,2, dimid, &
+          comp2_carid),'scriprmp_vector')
+      CALL hdlerr(NF_DEF_VAR &
+           (nc_projectionid, 'comp3_car', NF_DOUBLE,2, dimid, &
+           comp3_carid),'scriprmp_vector')
+      CALL hdlerr (NF_ENDDEF(nc_projectionid),'scriprmp_vector')
+
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+           (nc_projectionid, comp1_sphid, src_comp_ij(:,1)), &
+           'scriprmp_vector')
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+           (nc_projectionid, comp2_sphid, src_comp_ij(:,2)), &
+           'scriprmp_vector')
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+           (nc_projectionid, comp1_carid, src_comp_xyz(:,1)), &
+           'scriprmp_vector')
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+           (nc_projectionid, comp2_carid, src_comp_xyz(:,2)), &
+           'scriprmp_vector')
+      CALL hdlerr(NF_PUT_VAR_DOUBLE &
+           (nc_projectionid, comp3_carid, src_comp_xyz(:,3)), &
+           'scriprmp_vector')
+      CALL hdlerr(NF_CLOSE(nc_projectionid),'scriprmp_vector')
+#endif
+
+  ELSE
+     IF(.not. ll_src_spheric) THEN
+        IF(cfldtype == 'VECTOR_I') THEN 
+           src_comp_xyz(:,1) = &
+                src_array1(:) * trans1(:,1,1) + &
+                src_array2(:) * trans1(:,1,2)
+           src_comp_xyz(:,2) = &
+                src_array1(:) * trans1(:,2,1) + &
+                src_array2(:) * trans1(:,2,2)
+        ELSE
+           src_comp_xyz(:,1) = &
+                src_array2(:) * trans1(:,2,1) + &
+                src_array1(:) * trans1(:,2,2)
+
+           src_comp_xyz(:,2) = &
+                src_array1 * trans1(:,2,1) + &
+                src_array2(:) * trans1(:,2,2)
+
+        END IF
+     ELSE
+       IF(cfldtype == 'VECTOR_I') THEN 
+          src_comp_xyz(:,1) = src_array1(:)
+          src_comp_xyz(:,2) = src_array2(:)
+       ELSE
+          src_comp_xyz(:,1) = src_array2(:)
+          src_comp_xyz(:,2) = src_array1(:)
+       END IF
+    END IF
+     icomp = 2.
+  END IF   !lrotate
+
+!
+!*   4.2 Do interpolation 
+!        ----------------
+!* -- get matrix size
+! 
+  CALL hdlerr(NF_INQ_DIMID &
+     (nc_fileid, 'num_links', dimid1), 'scriprmp_vector')
+  CALL hdlerr(NF_INQ_DIMLEN &
+     (nc_fileid, dimid1, num_links), 'scriprmp_vector')
+!
+!* -- array allocation
+!
+  ALLOCATE (src_addr(num_links), dst_addr(num_links), &
+     weights(num_wgts,num_links))
+!
+!* -- read source grid addresses and weights
+!
+  CALL hdlerr(NF_INQ_VARID &
+     (nc_fileid, csrcadd, varid), 'scriprmp_vector')
+  CALL hdlerr(NF_GET_VAR_INT &
+     (nc_fileid, varid, src_addr), 'scriprmp_vector')
+  CALL hdlerr(NF_INQ_VARID &
+     (nc_fileid, cdstadd, varid), 'scriprmp_vector')
+  CALL hdlerr(NF_GET_VAR_INT &
+     (nc_fileid, varid, dst_addr), 'scriprmp_vector')
+  CALL hdlerr(NF_INQ_VARID &
+     (nc_fileid, cweight, varid), 'scriprmp_vector')
+  CALL hdlerr(NF_GET_VAR_DOUBLE &
+     (nc_fileid, varid, weights), 'scriprmp_vector') 
+  CALL hdlerr(NF_INQ_VARID &
+     (nc_fileid, cdstare, varid), 'scriprmp_vector')
+  CALL hdlerr(NF_GET_VAR_DOUBLE &
+     (nc_fileid, varid, dst_area), 'scriprmp_vector') 
+  CALL hdlerr(NF_INQ_VARID &
+     (nc_fileid, cdstfra, varid), 'scriprmp_vector')
+  CALL hdlerr(NF_GET_VAR_DOUBLE &
+     (nc_fileid, varid, dst_frac), 'scriprmp_vector') 
+!
+!* -- Do the matrix multiplication for the composants x, y and z
+!
+  dst_comp_xyz(:,:) = 0.
+
+  SELECT CASE (map_method)
+      
+  CASE ('CONSERV')     ! conservative remapping       
+      SELECT CASE (order)	  
+      CASE ('FIRST')        ! first order remapping 
+	  DO ib=1,icomp
+	    DO n = 1, num_links
+	      dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib)&
+		 + weights(1,n) * src_comp_xyz(src_addr(n),ib)
+	    END DO
+	  END DO
+      CASE ('SECOND')       ! second order remapping (including gradients)
+	  IF (cdgrdtyp .ne. 'LR') THEN
+	      WRITE (UNIT = nulou,FMT = *) &
+		 'Field gradient cannot be calculated'
+	      WRITE (UNIT = nulou,FMT = *) &
+		 'by Oasis as grid is not logically rectangular'
+	      CALL HALTE('STOP in scriprmp (CONSERV)')
+	  ENDIF
+	  ALLOCATE(gradient_lat(src_size2), gradient_lon(src_size2))
+	  
+	  DO ib=1,icomp
+	    CALL gradient(nlon_src2, nlat_src2, src_comp_xyz(:,ib), &
+	       sou_mask, src_lat2, src_lon2, id_nosper, &
+	       gradient_lat, gradient_lon)
+	    
+	    DO n = 1, num_links
+	      dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib)&
+		 + weights(1,n) * src_comp_xyz(src_addr(n),ib) &
+		 + weights(2,n) * gradient_lat(src_addr(n)) &
+		 + weights(3,n) * gradient_lon(src_addr(n))
+	    ENDDO
+	  END DO
+	  DEALLOCATE(gradient_lat, gradient_lon)	  
+      END SELECT! order      
+  CASE ('BILINEAR')        ! bilinear remapping 
+      DO ib=1,icomp
+	DO n = 1, num_links
+	  dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib) &
+	     + weights(1,n) * src_comp_xyz(src_addr(n),ib)
+	ENDDO
+      END DO
+  CASE ('BICUBIC')         ! bicubic remapping	
+      SELECT CASE (cdgrdtyp) !
+      CASE ('LR')          ! logically rectangular 	    
+	  ALLOCATE(gradient_i(src_size2), gradient_j(src_size2), &
+	     gradient_ij(src_size2))
+	  
+	  DO ib=1,icomp 
+	   CALL gradient_bicubic(nlon_src2,nlat_src2,src_comp_xyz(:,ib), &
+	      sou_mask, src_lat2, src_lon2, id_nosper, &
+	      gradient_i, gradient_j, gradient_ij)
+	    
+	    DO n = 1, num_links
+	      dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib) &
+		 + weights(1,n) * src_comp_xyz(src_addr(n),ib) &
+		 + weights(2,n) * gradient_i(src_addr(n)) &
+		 + weights(3,n) * gradient_j(src_addr(n)) &
+		 + weights(4,n) * gradient_ij(src_addr(n))
+	    ENDDO
+	  END DO
+	  DEALLOCATE(gradient_i, gradient_j, gradient_ij)	  
+      CASE ('D')           !reduced	  
+	  DO ib=1,icomp 
+	    DO n = 1, num_links
+	      dst_comp_xyz(dst_addr(n),ib) =  dst_comp_xyz(dst_addr(n),ib) &
+		 + weights(1,n) * src_comp_xyz(src_addr(n),ib)
+	    ENDDO
+	  ENDDO
+      END SELECT      
+  CASE ('DISTWGT')         ! distance weighted average
+      DO ib=1,icomp
+	DO n = 1, num_links
+	  dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib) &
+	     + weights(1,n) * src_comp_xyz(src_addr(n),ib)
+	ENDDO
+      ENDDO
+  CASE ('GAUSWGT')          ! distance gaussian weighted average
+      DO ib=1,icomp
+	DO n = 1, num_links
+	  dst_comp_xyz(dst_addr(n),ib) = dst_comp_xyz(dst_addr(n),ib) &
+	     + weights(1,n) * src_comp_xyz(src_addr(n),ib)
+	ENDDO
+      ENDDO      
+  END SELECT  ! remapping method
+
+  IF(lrotate) THEN
+!
+!*   4.3. Read and do the transformation from Cartesian to local referentials
+!         -------------------------------------------------------------------
+     dst_array(:) = 0.
+
+     CALL hdlerr(NF_INQ_VARID &
+          (nc_fileid, 'trans_car2loc',id_car2loc), 'scriprmp_vector')
+
+     CALL hdlerr(NF_GET_VAR_DOUBLE &
+          (nc_fileid, id_car2loc, trans_car2loc), 'scriprmp_vector') 
+
+     IF (cfldtype == 'VECTOR_I') THEN
+         IF (ll_same_dst_grids) THEN
+             DO n=1,dst_size        
+               dst_array(n) = &
+                  dst_comp_xyz(n,1) * trans_car2loc(n,1,1) + &
+                  dst_comp_xyz(n,2) * trans_car2loc(n,1,2) + &
+                  dst_comp_xyz(n,3) * trans_car2loc(n,1,3)
+
+               dst_array_assoc(n) = &
+                  dst_comp_xyz(n,1) * trans_car2loc(n,2,1) + &
+                  dst_comp_xyz(n,2) * trans_car2loc(n,2,2) + &
+                  dst_comp_xyz(n,3) * trans_car2loc(n,2,3)
+             ENDDO
+         ELSE
+             DO n=1,dst_size        
+               dst_array(n) = &
+                  dst_comp_xyz(n,1) * trans_car2loc(n,1,1) + &
+                  dst_comp_xyz(n,2) * trans_car2loc(n,1,2) + &
+                  dst_comp_xyz(n,3) * trans_car2loc(n,1,3)
+
+             ENDDO
+         ENDIF
+     ELSE
+        DO n=1,dst_size
+           dst_array(n) = &
+                dst_comp_xyz(n,1) * trans_car2loc(n,2,1) + &
+                dst_comp_xyz(n,2) * trans_car2loc(n,2,2) + &
+                dst_comp_xyz(n,3) * trans_car2loc(n,2,3)
+        ENDDO
+     END IF
+! 
+!* - test of 3-component which should be zero
+!
+#ifdef __DEBUG
+     dst_array_k(:) = 0.
+
+     DO n=1,dst_size
+        dst_array_k(n) = &
+             dst_comp_xyz(n,1) * trans_car2loc(n,3,1) + &
+             dst_comp_xyz(n,2) * trans_car2loc(n,3,2) + &
+             dst_comp_xyz(n,3) * trans_car2loc(n,3,3)
+     ENDDO
+!
+!* Write 3-component in netCDF file
+!
+     namelon = dst_name(1:kcount)//'.lon'
+     namelat = dst_name(1:kcount)//'.lat'
+     namefile = src_name2(1:icount)//'_to_'//&
+          dst_name(1:kcount)//'_'//map_method(1:7)//&
+          '_'//cfldtype//'_kcomp.nc'
+
+     CALL hdlerr(NF_CREATE &
+          (namefile,0,nc_testfileid), 'scriprmp_vector')
+
+     CALL hdlerr(NF_DEF_DIM &
+          (nc_testfileid,'dim_lon',nlon_dst,dimid_lon), &
+          'scriprmp_vector')
+
+     CALL hdlerr(NF_DEF_DIM &
+          (nc_testfileid,'dim_lat',nlat_dst,dimid_lat), &
+          'scriprmp_vector')
+
+     dimid_kcomp(1)=dimid_lon
+     dimid_kcomp(2)=dimid_lat
+
+     CALL hdlerr(NF_DEF_VAR &
+          (nc_testfileid,namelon,NF_DOUBLE,2,dimid_kcomp, id_lon), &
+          'scriprmp_vector')
+
+     CALL hdlerr(NF_DEF_VAR &
+          (nc_testfileid,namelat,NF_DOUBLE,2,dimid_kcomp, id_lat), &
+          'scriprmp_vector')
+
+     CALL hdlerr(NF_DEF_VAR &
+          (nc_testfileid,'k_comp',NF_DOUBLE,2,dimid_kcomp, id_kcomp), &
+          'scriprmp_vector')
+
+     CALL hdlerr(NF_PUT_ATT_TEXT &
+          (nc_testfileid, id_kcomp, LEN_TRIM('3-component values'), &
+          '3-component values'), 'scriprmp_vector')
+     
+     CALL hdlerr(NF_ENDDEF(nc_testfileid), 'scriprmp_vector')
+
+     CALL hdlerr(NF_PUT_VAR_DOUBLE &
+          (nc_testfileid,id_lon,dst_lon),'scriprmp_vector')
+
+     CALL hdlerr(NF_PUT_VAR_DOUBLE &
+          (nc_testfileid,id_lat,dst_lat),'scriprmp_vector')
+
+     CALL hdlerr(NF_PUT_VAR_DOUBLE &
+          (nc_testfileid,id_kcomp,dst_array_k),'scriprmp_vector')
+  
+     CALL hdlerr(NF_CLOSE(nc_testfileid),'scriprmp_vector') 
+
+     IF (nlogprt .GE. 2) THEN
+        WRITE (UNIT = nulou,FMT = *) &
+             'Test of 3-component done and written in file: ', &
+             namefile
+        WRITE (UNIT = nulou,FMT = *) ' '
+        CALL FLUSH (nulou)
+     ENDIF
+
+#endif
+
+  ELSE
+      dst_array(:) = dst_comp_xyz(:,1)
+      dst_array_assoc(:) = dst_comp_xyz(:,2)
+
+      IF(.not. ll_dst_spheric) THEN
+         dst_array(:) = dst_comp_xyz(:,1) * trans4(:,1,1) + &
+              dst_comp_xyz(:,2) * trans4(:,1,2)
+
+         dst_array_assoc(:) = dst_comp_xyz(:,1) * trans4(:,2,1) + &
+              dst_comp_xyz(:,2) * trans4(:,2,2)
+      ELSE
+         dst_array(:) = dst_comp_xyz(:,1)
+         dst_array_assoc(:) = dst_comp_xyz(:,2)
+      END IF
+
+  END IF  !lrotate
+   
+  CALL hdlerr(NF_CLOSE(nc_fileid),'scriprmp_vector')
+
+!
+!*    5. Check the cells on the poles
+!        ----------------------------
+!        ----------------------------
+!
+!* -- For the north pole _N and the south pole _S
+!
+  latpol_N = pi*half
+  latpol_S = -pi*half
+  compt_N = 0
+  moy_tmp_N = 0d0
+  moy_ERR_N = 0d0
+  compt_S = 0
+  moy_tmp_S = 0d0
+  moy_ERR_S = 0d0
+
+  DO n = 1, dst_size
+    IF (dst_lat(n) == latpol_N) THEN
+	moy_tmp_N = moy_tmp_N + dst_array(n)
+	moy_err_N = moy_err_N + dst_err(n)
+	compt_N = compt_N + 1
+    ELSE IF (dst_lat(n) == latpol_S) THEN
+	moy_tmp_S = moy_tmp_S + dst_array(n)
+	moy_err_S = moy_err_S + dst_err(n)
+	compt_S = compt_S + 1
+    END IF
+  END DO
+
+  IF (compt_N/=0) THEN
+      moy_tmp_N = moy_tmp_N/compt_N
+      moy_err_N = moy_err_N/compt_N
+      DO n = 1, num_links
+	IF (dst_lat(dst_addr(n)) == latpol_N) THEN
+	    dst_array(dst_addr(n)) = moy_tmp_N
+	    dst_err(dst_addr(n)) = moy_err_N
+	END IF
+      END DO
+      PRINT*, 'Points at the pole N'
+      PRINT*, 'Average value at the pole : ', moy_tmp_N
+      PRINT*, 'Average error at the pole : ', moy_err_N
+  ELSE
+      PRINT*, 'No point at the pole N'
+  END IF
+
+  IF (compt_S/=0) THEN
+      moy_tmp_S = moy_tmp_S/compt_S
+      moy_err_S = moy_err_S/compt_S
+      DO n = 1, num_links
+	IF (dst_lat(dst_addr(n)) == latpol_S) THEN
+	    dst_array(dst_addr(n)) = moy_tmp_S
+	    dst_err(dst_addr(n)) = moy_err_S
+	END IF
+      END DO
+      PRINT*, 'Points at the pole S'
+      PRINT*, 'Average value at the pole : ', moy_tmp_S
+      PRINT*, 'Average error at the pole : ', moy_err_S
+  ELSE
+      PRINT*, 'No point at the pole S'
+  END IF
+
+  DEALLOCATE (src_addr, dst_addr, weights)
+  DEALLOCATE(src_array1, src_array2, &
+       src_mask1,src_mask2,src_lon1,src_lat1,src_lon2,src_lat2)
+!
+!*  6. End of routine 
+!      --------------
+!      --------------
+!
+ENDIF
+  IF (nlogprt .GE. 2) THEN
+     WRITE (UNIT = nulou,FMT = *) ' '
+     WRITE (UNIT = nulou,FMT = *) &
+          '          --------- End of routine scriprmp_vector ---------'
+     CALL FLUSH (nulou)
+  ENDIF
+
+END SUBROUTINE scriprmp_vector
Index: CPL/oasis3/trunk/src/lib/scrip/src/timers.f
===================================================================
--- CPL/oasis3/trunk/src/lib/scrip/src/timers.f	(revision 1677)
+++ CPL/oasis3/trunk/src/lib/scrip/src/timers.f	(revision 1677)
@@ -0,0 +1,343 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This module uses F90 cpu time routines to allowing setting of
+!     multiple CPU timers.
+!
+!-----------------------------------------------------------------------
+!
+!     CVS:$Id: timers.f,v 1.1.1.1 2005/03/23 16:01:12 adm Exp $
+!
+!     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 timers
+
+!-----------------------------------------------------------------------
+
+      use kinds_mod
+
+      implicit none
+
+      integer (kind=int_kind), parameter ::  
+     &     max_timers = 99  ! max number of timers allowed
+
+      integer (kind=int_kind), save :: 
+     &     cycles_max       ! max value of clock allowed by system
+
+      integer (kind=int_kind), dimension(max_timers), save :: 
+     &     cycles1,         ! cycle number at start for each timer
+     &     cycles2          ! cycle number at stop  for each timer
+
+      real (kind=real_kind), save ::  
+     &     clock_rate       ! clock_rate in seconds for each cycle
+
+      real (kind=real_kind), dimension(max_timers), save ::  
+     &     cputime          ! accumulated cpu time in each timer
+
+      character (len=8), dimension(max_timers), save ::  
+     &     status           ! timer status string
+
+!***********************************************************************
+
+      contains
+
+!***********************************************************************
+
+      subroutine timer_check(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine checks a given timer.  This is primarily used to
+!     periodically accumulate time in the timer to prevent timer cycles
+!     from wrapping around max_cycles.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+
+      if (status(timer) .eq. 'running') then
+        call timer_stop (timer)
+        call timer_start(timer)
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine timer_check
+
+!***********************************************************************
+
+      subroutine timer_clear(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine resets a given timer.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+
+      cputime(timer) = 0.0_real_kind  ! clear the timer
+
+!-----------------------------------------------------------------------
+
+      end subroutine timer_clear
+
+!***********************************************************************
+
+      function timer_get(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine returns the result of a given timer.  This can be
+!     called instead of timer_print so that the calling routine can 
+!     print it in desired format.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+!
+!     Output Variables:
+!
+!-----------------------------------------------------------------------
+
+      real (kind=real_kind) ::  
+     &     timer_get   ! accumulated cputime in given timer
+
+!-----------------------------------------------------------------------
+
+      if (status(timer) .eq. 'stopped') then
+        timer_get = cputime(timer)
+      else
+        call timer_stop(timer)
+        timer_get = cputime(timer)
+        call timer_start(timer)
+      endif
+
+!-----------------------------------------------------------------------
+
+      end function timer_get
+
+!***********************************************************************
+
+      subroutine timer_print(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine prints the accumulated cpu time in given timer.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+
+      !--- 
+      !--- print the cputime accumulated for timer 
+      !--- make sure timer is stopped
+      !---
+
+      if (status(timer) .eq. 'stopped') then
+        write(*,"(' CPU time for timer',i3,':',1p,e16.8)")  
+     &       timer,cputime(timer)
+      else
+        call timer_stop(timer)
+        write(*,"(' CPU time for timer',i3,':',1p,e16.8)")  
+     &       timer,cputime(timer)
+        call timer_start(timer)
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine timer_print
+
+!***********************************************************************
+
+      subroutine timer_start(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine starts a given timer.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+
+      !---
+      !--- Start the timer and change timer status.
+      !---
+
+      if (status(timer) .eq. 'stopped') then
+        call system_clock(count=cycles1(timer))
+        status(timer) = 'running'
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine timer_start
+
+!***********************************************************************
+
+      subroutine timer_stop(timer)
+
+!-----------------------------------------------------------------------
+!
+!     This routine stops a given timer.
+!
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!
+!     Input Variables:
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind), intent(in) ::  
+     &    timer            ! timer number
+
+!-----------------------------------------------------------------------
+
+      if (status(timer) .eq. 'running') then
+
+        !---
+        !--- Stop the desired timer.
+        !---
+
+        call system_clock(count=cycles2(timer))
+
+        !---
+        !--- check and correct for cycle wrapping
+        !---
+
+        if (cycles2(timer) .ge. cycles1(timer)) then
+          cputime(timer) = cputime(timer) + clock_rate*  
+     &                     (cycles2(timer) - cycles1(timer))
+        else
+          cputime(timer) = cputime(timer) + clock_rate*  
+     &                (cycles2(timer) - cycles1(timer) + cycles_max)
+        endif
+
+        !---
+        !--- Change timer status.
+        !---
+
+        status(timer)='stopped'
+
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine timer_stop
+
+!***********************************************************************
+
+      subroutine timers_init
+
+!-----------------------------------------------------------------------
+!
+!     This routine initializes some machine parameters necessary for
+!     computing cpu time from F90 intrinsics.
+!
+!-----------------------------------------------------------------------
+
+      integer (kind=int_kind) :: cycles ! count rate return by sys_clock
+
+!-----------------------------------------------------------------------
+
+      !---
+      !--- Initialize timer arrays and clock_rate.
+      !---
+
+      clock_rate = 0.0_real_kind
+      cycles1    = 0
+      cycles2    = 0
+      cputime    = 0.0_real_kind
+      status     = 'stopped'
+
+      !---
+      !--- Call F90 intrinsic system_clock to determine clock rate
+      !--- and maximum cycles.  If no clock available, print message.
+      !---
+
+      call system_clock(count_rate=cycles, count_max=cycles_max)
+
+      if (cycles /= 0) then
+        clock_rate = 1.0_real_kind/real(cycles)
+      else
+        clock_rate = 0.0_real_kind
+        print *, '--- No system clock available ---'
+      endif
+
+!-----------------------------------------------------------------------
+
+      end subroutine timers_init
+
+!***********************************************************************
+
+      end module timers
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: CPL/oasis3/trunk/src/mod/oasis3/COPYRIGHT
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/COPYRIGHT	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/COPYRIGHT	(revision 1677)
@@ -0,0 +1,44 @@
+Copyright
+=========
+
+Copyright š 2004 Centre Europeen de Recherche et Formation
+Avancee en Calcul Scientifique (CERFACS).  
+
+This software and ancillary information called OASIS3 is free
+software.  CERFACS has rights to use, reproduce, and distribute
+OASIS3. The public may copy, distribute, use, prepare derivative works and
+publicly display OASIS3 under the terms of the Lesser GNU General
+Public License (LGPL) as published by the Free Software Foundation,
+provided that this notice and any statement of authorship are
+reproduced on all copies. If OASIS3 is modified to produce derivative
+works, such modified software should be clearly marked, so as not to
+confuse it with the OASIS3 version available from CERFACS.
+
+The developers of the OASIS3 software are researchers attempting to
+build a modular and user-friendly coupler accessible to the climate
+modelling community. Although we use the tool ourselves and have made
+every effort to ensure its accuracy, we can not make any
+guarantees. We provide the software to you for free. In return,
+you--the user--assume full responsibility for use of the software. The
+OASIS3 software comes without any warranties (implied or expressed) and
+is not guaranteed to work for you or on your computer. Specifically,
+CERFACS and the various individuals involved in development and
+maintenance of the OASIS3 software are not responsible for any damage
+that may result from correct or incorrect use of this software.
+
+Reference to the software:
+=========================
+
+If you feel that your research has benefited from the use of the OASIS3
+software, we will greatly appreciate your reference to the following 
+report:
+
+Sophie Valcke, Arnaud Caubel, Reiner Vogelsang, Damien Declat, 2004:  
+OASIS3 User Guide (prism_2-4). PRISM Report Series, No 2, 5th Ed., 60 pp.
+ 
+======================================================================
+
+This version of OASIS was developed under the EU FP6 PRISM project           
+contract NO: EVR1-CT-2001-40012-PRISM, in collaboration with
+FUJITSU SYSTEMS EUROPE and SGI GERMANY.
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG.bbl
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG.bbl	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG.bbl	(revision 1677)
@@ -0,0 +1,15 @@
+\newpage
+\begin{thebibliography}{10}
+
+\bibitem{SCRIPR}http://climate.lanl.gov/Software/SCRIP/index.htm
+
+\bibitem{mpp_io}http://www.gfdl.gov/\~~vb/mpp\_io.html
+
+\bibitem{udunits}http://www.unidata.ucar.edu/packages/udunits/udunits.dat
+
+\bibitem{wp3i}http://prism.dkrz.de/Workpackages/WP3i
+ 
+% http://www.cgd.ucar.edu/cms/eaton/cf-metadata/index.html
+
+
+\end{thebibliography}
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG.tex	(revision 1677)
@@ -0,0 +1,80 @@
+%
+% OASIS 3.0 doc
+% -------------
+%
+% 2002
+%
+% - pagination -
+% 
+%\documentstyle[jeep,12pt,psfig]{article}
+\documentclass[12pt]{article}
+\usepackage{graphicx} 
+\setlength{\topmargin}{0.0cm}
+\setlength{\oddsidemargin}{-.2cm}
+\setlength{\textheight}{24.0cm}
+\setlength{\textwidth}{15.5cm}
+\setlength{\headsep}{.0in}
+%\setlength{\footheight}{.0in}
+%\setlength{\parindent}{.0in}
+\usepackage{fancyhdr}
+\pagestyle{fancy}
+\renewcommand{\headrulewidth}{0pt}
+\lhead{}
+\rhead{}
+\cfoot{}
+\chead{}
+\rfoot{CERFACS TR/CMGC/04/48}
+%\rfoot{PRISM Project Report XXXX}
+%\lfoot{\footnotesize PRISM Project _ XXXXX}
+%\rfoot{\footnotesize OASIS3}
+\cfoot{\thepage}
+%
+% - nouvelles commandes -
+%
+\newcommand{\name}[2]{\newpage
+    \noindent \makebox[8.0cm][l]{\large \bf #1} \makebox[7.3cm][r]{\bf #2} 
+    \newline
+    \rule{\textwidth}{0.6mm} \newline
+    \vspace*{1.2cm} \newline
+}
+%
+% - debut doc -
+%
+\small
+\begin{document}
+\bibliographystyle{plain}
+%
+% > couverture
+	\input UG0_Coverage.tex
+%
+% > table des matieres
+        \newpage
+        \vspace*{1.0cm}
+	.
+	\newpage
+        \tableofcontents
+%
+% > introduction
+	\input UG_Acknowledgements.tex
+	\input UG0_Stepbystep_overview.tex
+	\input UG1_Obtaining.tex
+	\input UG2_Model_interfacing.tex
+	\input UG3_Namcouple_generation.tex
+        \input UG4_Transformations.tex
+        \input UG5_Auxiliary_files.tex
+        \input UG6_Compilation_running.tex
+% > appendices
+        \input UGA1_Grid_description.tex
+        \input UGA4_changes.tex
+        \input UGA3_couplings.tex
+        \input UGA2_SCRIP.tex
+        \input UGA3_couplings.tex
+        \input UGA4_changes.tex
+%        \input UGA3_SIPC_GMEM_API.tex
+%	\input UGA4_PIPE_API.tex
+%
+\bibliography{oasis}
+\end{document}
+%
+% - fin doc -
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Coverage.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Coverage.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Coverage.tex	(revision 1677)
@@ -0,0 +1,61 @@
+\newpage
+%\thispagestyle{empty}
+%\begin{figure}
+%\includegraphics[scale=.8]{cover.eps} 
+%\label{cover}
+%\end{figure}
+%\vspace{50mm}
+
+
+%\eject
+%\clearpage
+%\thispagestyle{empty}
+%.
+
+%\newpage
+\vspace*{0.5cm}
+{\Large
+   \begin{center}
+      OASIS3\\
+      {\bf O}cean {\bf A}tmosphere {\bf S}ea  {\bf I}ce  {\bf S}oil\\
+      \vspace{0.4cm}
+      User's Guide \\
+      \vspace{0.4cm}
+      {\large oasis3\_prism\_2-2, June 2004}
+
+   \end{center}
+}
+
+\vspace*{1cm}
+
+\centerline{Sophie Valcke$^1$, Arnaud Caubel$^2$, Reiner
+  Vogelsang$^3$, Damien Declat$^1$}
+
+\vspace*{1cm}
+\centerline{PRISM Project WP3a}
+\centerline{$^1$C.E.R.F.A.C.S.}
+\centerline{$^2$FECIT/Fujitsu}
+\centerline{$^3$SGI Germany}
+
+\begin{abstract}
+This User's Guide contains a detailed step-by-step description on 
+how to realize a coupled simulation with OASIS3.
+
+The aim of OASIS3 is to provide a flexible and user friendly tool 
+for coupling independent
+general circulation models of the atmosphere and the ocean (A/O-GCMs) 
+as well as other climate component models (sea-ice, land,
+atmospheric chemistry, ocean biogeochemistry, ...) and regional models. 
+The resulting coupled models are necessary tools to tackle
+current climatic paradigms such as the natural variability, 
+El Ni\~no Southern Oscillation
+(ENSO) or the greenhouse gas global warming effect. 
+
+OASIS3 synchronizes the exchanges of coupling fields between 
+the models being coupled, and performs 
+2D interpolations and transformations needed to express, on the grid
+of the target model, the coupling
+fields produced by the source model on its grid. Modularity and
+flexibility have been particularly emphasized in OASIS3 design.
+
+\end{abstract}
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Stepbystep_overview.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Stepbystep_overview.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG0_Stepbystep_overview.tex	(revision 1677)
@@ -0,0 +1,48 @@
+\newpage
+\chapter{Overview of step-by-step use of OASIS3}
+\label{sec_step}
+To use OASIS3 for coupling models and/or perform I/O
+actions, one has to follow these steps:
+\begin{enumerate}
+\item Obtain OASIS3 sources. (See section \ref{sec_Obtaining}).
+\item Identify the coupling or I/O fields and adapt the component
+models to allow their exchange with the PSMILe library based on MPI1
+or MPI2 message passing\footnote{In OASIS3, the SIPC technique has
+also been maintained; for a practical toy model example, see the
+sources in {\tt /prism/src/mod/sipcatmos, /sipcocean} and the running
+script and README in {\tt /prism/util/running/toysvipc} (available
+from CERFACS CVS Server only). The PIPE and GMEM communication
+techniques should still work but are not maintained anymore and were
+not tested.}.  The PSMILe library is interfaced with the {\tt mpp\_io}
+library from GFDL \cite{mpp_io} and therefore can be used to perform
+I/O actions from/to disk files.  For more detail on how to interface a
+model with the PSMILe, see section \ref{sec_modelinterfacing}. The
+TOYCLIM coupled model gives a practical example of toy models; the
+sources are given in directories {\tt /prism/src/mod/toyatm, /toyoce,
+/toyche} and more details can be found in \cite{car04a}.
+
+\item Define all coupling and I/O parameters and the transformations
+  required to adapt each coupling field from its source model grid to
+  its target model grid; prepare OASIS3 configuring file {\it
+  namcouple}. OASIS3 supports many interpolation
+  algorithms as it is
+  interfaced with the SCRIP 1.4 library \cite{SCRIPR} (see appendix
+  \ref{sec_SCRIP}). (See sections \ref{sec_namcouple} and
+  \ref{sec_transformations}).
+\item Generate required auxiliary data files. (See section
+  \ref{sec_auxiliary}).
+\item Compile OASIS3, the component models and start the coupled
+experiment. OASIS3 and the TOYCLIM coupled model use the PRISM
+standard compiling environment (SCE) and standard running environment
+(SRE). (See section \ref{sec_compilationrunning}).
+
+\end{enumerate}
+
+OASIS3 and the TOYCLIM coupled model has successfully run on Fujitsu
+VPP5000, NEC SX5 and SX6, SGI IRIX64, SGI Origin 3800, Linux Opteron,
+IBM Power4, and Cray X1. The appendix \ref{sec_couplings} lists (some of) the coupled
+models realized with OASIS within the past 5 years or so.  
+
+If you need extra help, do not hesitate to contact us (see contact
+details on the back of the cover page).
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG1_Obtaining.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG1_Obtaining.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG1_Obtaining.tex	(revision 1677)
@@ -0,0 +1,78 @@
+\newpage
+\chapter{Obtaining OASIS3 sources}
+\label{sec_Obtaining}
+%               ----------------------------------
+%
+\section{The OASIS3 package}
+
+The sources and data of OASIS3, all related libraries, and TOYCLIM coupled model are
+available from PRISM CVS server \texttt{bedano} and from CERFACS CVS
+server \texttt{elnino}.
+
+From PRISM CVS server (see more details in \cite{leg04} or refer to the
+PRISM web 'Download' page at \break http://prism.enes.org), these
+sources  and data can
+be retrieved with the following CVS module names:
+
+\begin{Indent} 
+
+{\em TOYCLIM}: sources of OASIS3, toyoce, toyatm and toyche,
+associated libraries, utilities, input and example output data files; \\
+{\em TOYCLIMSRC}:  only the sources of OASIS3, toyoce, toyatm
+and toyche, associated libraries and utilities;\\
+{\em TOYCLIMATA}: only the input and example output data files.
+\end{Indent} 
+
+On CERFACS CVS server, the repository is {\tt /home/valcke/PRISMCVS}.
+To obtain the CVS login and password as well as the most recent OASIS3
+tag, please contact us (see contact details on the back of the cover
+page).  
+
+OASIS3 directory structure follows the PRISM standard one (some
+sources, related to the SIPC or NONE communication techniques, are
+available from CERFACS CVS server only):
+
+\begin{verbatim}
+ - prism/data/testinterp    data for OASIS3 in interpolator mode NONE
+                            (CERFACS CVS only)
+             /toyclim       data and results for TOYCLIM coupled model
+             /toysvipc      data for the SIPC toy model
+                            (CERFACS CVS only)  
+               
+ - prism/src/lib/anaisg     GAUSSIAN interpolation library
+                /anaism     SURFMESH interpolation library
+                /clim       CLIM/MPI1-MPI2 communication library
+                /fscint     INTERP interpolation library  
+                /mpp_io     I/O library
+                /psmile     PRISM System Model Interface Library
+                /scrip      SCRIPR interpolation library
+                /sipc
+                /svipc      SIPC communication library
+                            (CERFACS CVS only)
+                  
+ - prism/src/mod/oasis3/src OASIS3 main code
+                       /doc OASIS3 documentation
+
+                /sipcatmos  SIPC toy model 1 (CERFACS CVS only)
+                /sipcocean  SIPC toy model 2 (CERFACS CVS only)
+                  
+                /toyatm     TOYCLIM component model 1 and documentation
+                /toyoce     TOYCLIM component model 2
+                /toyche     TOYCLIM component model 3
+                
+ - prism/util/compile/frames  PRISM Standard Compiling Environment (SCE)
+ 
+ - prism/util/running/frames  PRISM Standard Running Environment (SRE) 
+ 
+ - prism/util/running/adjunct_file configuring files for OASIS3 
+                     /testinterp   environment to test the interpolator
+                                   mode NONE (CERFACS CVS only) 
+                     /toysvipc     environment to run the SIPC toymodel
+                                   (CERFACS CVS only)    
+                             
+\end{verbatim}
+%                              
+% 
+%                  /sxgmem/    GMEM communication library
+%
+%\end{verbatim}
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG2_Model_interfacing.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG2_Model_interfacing.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG2_Model_interfacing.tex	(revision 1677)
@@ -0,0 +1,888 @@
+\newpage
+\chapter{Interfacing a model with the PSMILe library}
+\label{sec_modelinterfacing}
+
+At run-time, OASIS3 acts as a separate mono process executable which
+drives the coupled run, interpolates and transforms the coupling
+fields. To communicate with OASIS3 or directly between the component
+models, different communication techniques have been historically
+developed. The technique used for one particular run is defined by the
+user in the configuration file {\it namcouple} (see section
+\ref{sec_namcouple}). In OASIS3, the CLIM communication technique
+based on MPI1 or MPI2 message passing and the associated model
+interface library PSMILe, should be used\footnote{The SIPC technique,
+based on UNIX shared-memory segments, was also maintained; for a
+practical toy model example using SIPC, see the sources in {\tt
+/prism/src/mod/sipcatmos, /sipcocean} and some explanations in {\tt
+/prism/util/running/toysvipc} (from CERFACS CVS only).}. For a practical toy model 
+using the PSMILe library, see the sources in {\tt /prism/src/mod/toyatm,
+/toyche, /toyoce} and more details in \cite{val04b} .
+
+
+%\vspace*{0.5cm}
+
+ To communicate with OASIS3 or directly with another component model
+ using the CLIM/MPI communication technique,
+  or to perform I/O actions, a component model needs to be interfaced
+  with the PRISM System Model Interface library, PSMILe, which sources
+  can be found in {\tt prism/src/lib/psmile} directory. PSMILe supports:
+
+\begin{itemize}
+\item parallel communication between a parallel component
+ model and OASIS3 main process,
+\item direct communication between two parallel component models when no
+ transformations and no repartitioning are required,
+\item automatic sending and receiving actions at appropriate times
+ following user's choice indicated in the {\it namcouple},
+\item time integration or accumulation of the coupling fields,
+\item I/O actions from/to files.
+\end{itemize}
+
+ To adapt a component model to PSMILe, specific calls of
+ the following classes have to be implemented in the code:
+
+\begin{enumerate}
+\item Initialisation (section \ref{subsubsec_Initialisation})
+\item Grid data file definition (section \ref{subsubsec_griddef})
+\item Partition definition (section \ref{subsubsec_Partition})
+\item I/O-coupling field declaration (section \ref{subsubsec_Declaration})
+\item End of definition phase (section \ref{subsubsec_Endofdefinition})
+\item I/O-coupling field sending and receiving (section
+\ref{subsubsec_sendingreceiving})
+\item Termination (section \ref{subsubsec_Termination})
+\end{enumerate}
+
+Finally, in section \ref{subsubsec_Algoritms}, different coupling
+algorithms are illustrated, and explanations are given on how to
+reproduce them with PSMILe by defining the appropriate indices of
+lag and sequence for each coupling field.
+
+\section{Initialisation}
+\label{subsubsec_Initialisation}
+%{Initialisation}
+
+All processes initialise the coupling and, if required, retrieve a
+local communicator for the component model internal parallelisation.
+
+\begin{itemize}
+
+\item {\tt USE mod\_prism\_proto}
+ 
+Module to be used by the component models. 
+
+\item {\tt CALL prism\_init\_comp\_proto (compid, model\_name, ierror)} 
+
+ \begin{itemize}
+   \item {\tt compid [INTEGER; OUT]}: component model ID 
+   \item {\tt model\_name [CHARACTER*6; IN]}: name of calling model (as in
+  {\em namcouple}) 
+   \item {\tt ierror [INTEGER; OUT]}: returned error code.
+ \end{itemize}
+ 
+Routine called by all component model processes, which initialises the
+coupling.\footnote{The model may call MPI\_Init explicitly, but if so, has to
+call it before calling {\tt prism\_init\_comp\_proto}; in this case, the
+model also has to call MPI\_Finalize explicitly, but only after calling
+{\tt prism\_terminate\_proto}.}
+
+\item {\tt CALL prism\_get\_localcomm\_proto (local\_comm, ierror )}
+
+ \begin{itemize}
+   \item {\tt local\_comm [INTEGER; OUT]}: value of local communicator
+   \item {\tt ierror [INTEGER; OUT]}: returned error code.
+  \end{itemize}
+
+For MPI1: routine called by all model processes to get the value of a local
+communicator to be used by the model for its internal
+parallelisation. 
+
+In fact, with MPI1, all component models started in a pseudo-MPMD mode
+share automatically the same MPI\_COMM\_WORLD communicator. Another
+communicator has to be used for the internal parallelisation of each
+model. OASIS3 creates this model local communicator following a
+``coloring scheme"; its value is returned as the first argument of
+prism\_get\_localcomm\_proto routine.
+
+With MPI2, the communicator
+MPI\_COMM\_WORLD will be returned as local communicator.
+
+Besides that, the differences between using PSMILe with MPI1 or MPI2 message passing are
+\begin{itemize}
+ \item The \$CHANNEL in the namcouple; see section \ref{subsec_namcouplefirst}. 
+ \item The way the models
+are started. With MPI2, only OASIS3 needs to be started at the command line;
+it will then spawn the component models at the beginning of the run.
+With MPI1, models have to be started by the user in a pseudo-MPMD
+mode; the way to do this depends on the computing platform. For more details, see section \ref{subsec_running}.
+\end{itemize} 
+\end{itemize}  
+
+\section{Grid data file definition}
+\label{subsubsec_griddef}
+
+The grid data files {\em grids.nc, masks.nc} and {\em areas.nc} must
+be created by the user before the run, or can be written directly
+at run time by the component models. 
+
+If written by the component models, the writing of those grid files is
+driven by OASIS3 main process. It first checks whether the binary file
+{\em grids} or the netCDF file {\em grids.nc} exists (in that case, it
+is assumed that {\em areas} or {\em areas.nc} and {\em masks} or {\em
+masks.nc} files exist too), or if writing is needed. If {\em grids} or
+{\em grids.nc} exists, it must contain all grid information from all
+models; if it does not exist, each model must write its grid
+definition in the grid data files.
+
+The coupler sends the information on whether or not writing is needed
+to the mo\-dels following an OASIS internal order (below
+prism\_start\_grids\_writing). If no writing is needed, nothing
+happens when calling the following prism\_write\_xxxx routines. If
+writing is needed, the first model creates the files, writes the data
+arrays (with {\tt prism\_write\_grid}, {\tt prism\_write\_corner},
+{\tt prism\_write\_mask}, {\tt prism\_write\_area} calls),
+and then sends a termination flag to the coupler (below \break {\tt
+prism\_terminate\_grids\_writing} call). The coupler will send the
+starting flag to the next model; this ensures that only one model
+accesses the files at a time.
+
+This section describes the PSMILe routines that may be called by the
+master process of each component model to write, at run time, the whole
+grid information to the grid data files. These routines have to
+be called just after {\tt prism\_init\_comp\_proto}.
+
+The TOYCLIM coupled model (see the sources of the toy
+component models in {\tt prism/\-src/mod/toyatm, /toyoce, and /toyche})
+uses those routines to write its grid data
+files if \texttt{gridswr=1} in the running script
+\texttt{RUN\_toyclim\_$<$expid$>$} (see section \ref{subsec_running}).
+
+%To run a toy experiment
+%into which the component models write those files, execute the
+%script prism/util/running/toyclim/sc\_run\_toyclim\_grid. 
+
+\begin{itemize}
+\item {\tt USE  mod\_prism\_grids\_writing}
+
+Module to be used by the component model to call grid writing routines.
+  
+\item {\tt CALL  prism\_start\_grids\_writing (flag)}
+        
+  \begin{itemize}
+    \item {\tt flag [INTEGER; OUT]}:  returns 1/0 if grids writing is
+    needed/not needed
+  \end{itemize}
+Initialisation of grids writing.
+
+\item {\tt CALL prism\_write\_grid (cgrid, nx, ny, lon, lat)}
+        
+ \begin{itemize}
+    \item {\tt cgrid [CHARACTER*4; IN]}: grid name prefix (see
+    \ref{subsec_namcouplesecond}
+    \item {\tt nx [INTEGER; IN]} : grid dimension in x-direction
+    \item {\tt ny [INTEGER; IN]} : grid dimension in y-direction
+    \item {\tt lon [REAL, DIMENSION(nx,ny); IN)} : array of longitudes
+      (degrees East) 
+    \item {\tt lat [REAL, DIMENSION(nx,ny); IN)} : array of latitudes
+    (degrees North)
+ \end{itemize}
+Writing of the model grid longitudes and latitudes. Note that OASIS
+automatically detects overlapping grid points (which is essential to
+have a correct conservative remapping \texttt{SCRIPR/CONSERV}, see
+section \ref{subsec_interp}) only if their longitude is given with the
+same number (e.g. 360.0 for both, not 450.0 for one and 90.0 for the
+other).
+
+
+\item {\tt CALL prism\_write\_corner (cgrid, nx, ny, nc, clon, clat)}
+
+ \begin{itemize}
+    \item {\tt cgrid [CHARACTER*4; IN]}: grid name prefix
+    \item {\tt nx [INTEGER; IN]} : grid dimension in x-direction
+    \item {\tt ny [INTEGER; IN]} : grid dimension in y-direction
+    \item {\tt nc [INTEGER; IN]} : number of corners per grid cell (4)
+    \item {\tt lon [REAL, DIMENSION (nx,ny,nc);IN]} : array of corner
+    longitudes (in degrees\_East)
+    \item {\tt lat [REAL, DIMENSION (nx,ny,nc);IN]} : array of corner
+    latitudes (in degrees\_North)
+ \end{itemize}
+Writing of the grid cell corner longitudes and latitudes
+(counterclockwise sense). Writing of corners is optional as corner
+information is needed only for some transformations (see section
+\ref{subsec_griddata}). If called, prism\_write\_corners needs to be
+called after prism\_write\_grids.
+
+\item {\tt CALL prism\_write\_mask (cgrid, nx, ny, mask)}
+ \begin{itemize}
+    \item {\tt cgrid [CHARACTER*4; IN]}: grid name prefix 
+    \item {\tt nx [INTEGER; IN]} : grid dimension in x-direction
+    \item {\tt ny [INTEGER; IN]} : grid dimension in y-direction
+    \item {\tt mask [INTEGER, DIMENSION(nx,ny) ;IN]} : mask array (0 - not masked, 1 - masked)
+ \end{itemize}
+Writing of the model grid mask.
+
+\item {\tt CALL prism\_write\_area (cgrid, nx, ny, area)}
+ \begin{itemize}
+    \item {\tt cgrid [CHARACTER*4; IN]}: grid name prefix
+    \item {\tt nx [INTEGER; IN]} : grid dimension in x-direction
+    \item {\tt ny [INTEGER; IN]} : grid dimension in y-direction
+    \item {\tt area [REAL, DIMENSION(nx,ny); IN]} : array of grid cell areas
+ \end{itemize}
+Writing of the model grid cell areas. Writing of areas is optional as
+area information is needed only for some transformations (see section
+\ref{subsec_griddata}).
+
+\item {\tt CALL prism\_terminate\_grids\_writing()}
+
+Termination of grids writing. A flag stating that all needed grid
+information was written will be sent to OASIS3 main process.
+
+\end{itemize}
+
+\section{Partition definition}
+\label{subsubsec_Partition}
+
+When a component of the coupled system is a parallel code, each
+coupling field is usually scattered among the different
+processes. With the PSMILe library, each process sends
+directly its partition to OASIS3 main process or directly to the
+other component model if no transformation nor repartition is
+required.  To do so, each process implied in the coupling has to
+define its local partition in the global index space.
+
+\begin{itemize}
+
+\item {\tt USE mod\_prism\_def\_partition\_proto}
+
+Module to be used by the component model to call {\tt
+  prism\_def\_partition\_proto}.
+
+\item {\tt CALL prism\_def\_partition\_proto (il\_part\_id,
+   ig\_paral, ierror)}
+   \begin{itemize}
+   \item {\tt il\_part\_id [INTEGER; OUT]}: partition ID 
+   \item {\tt ig\_paral [INTEGER, DIMENSION(:), IN]}: vector of
+   integers describing the local partition in the global index space
+   \item {\tt ierror [INTEGER; OUT]}: returned error code.
+   \end{itemize}
+\end{itemize} 
+
+The vector of integers describing the process local partition, {\tt
+ig\_paral}, has a different expression depending on the type of the
+partition. In OASIS3, 4 types of partition are supported: Serial (no
+partition), Apple, Box, and Orange.
+ 
+\subsection{Serial (no partition)}
+
+This is the choice for a monoprocess model. In this case, we have 
+{\tt ig\_paral(1:3)}:
+\begin{itemize}
+ \item {\tt ig\_paral(1)} = 0 (indicates a Serial ``partition'')
+ \item {\tt ig\_paral(2)} = 0
+ \item {\tt ig\_paral(3)} = the total grid size.
+\end{itemize}
+
+\subsection{Apple partition} 
+
+Each partition is a segment of the global domain, described by its
+global offset and its local size. In this case, we have {\tt
+ig\_paral(1:3)}:
+\begin{itemize}
+ \item {\tt ig\_paral(1)} = 1 (indicates an Apple partition)
+ \item {\tt ig\_paral(2)} = the segment global offset
+ \item {\tt ig\_paral(3)} = the segment local size
+\end{itemize}
+
+Figure \ref{apple_partition} illustrates an Apple partition over 3
+processes.
+\begin{figure}
+\includegraphics[scale=.6]{apple_new.eps} 
+\caption{Apple partition}
+\label{apple_partition}
+\end{figure}
+
+
+\subsection{Box partition} 
+
+Each partition is a rectangular region of the global domain, described
+by the global offset of its upper left corner, and its local extents in the
+X and Y dimensions. The global extent in the X dimension must also be
+given. In this case, we have {\tt ig\_paral(1:5)}:
+\begin{itemize}
+ \item {\tt ig\_paral(1)} = 2 (indicates a Box partition)
+ \item {\tt ig\_paral(2)} = the upper left corner global offset
+ \item {\tt ig\_paral(3)} = the local extent in X
+ \item {\tt ig\_paral(4)} = the local extent in Y\footnote{The maximum
+value of the local extent in Y is presently 338; it can be increased
+by modifying the value of {\tt Clim\_MaxSegments} in {\tt
+prism/src/lib/clim/src/mod\_clim.F90} and in {\tt
+prism/src/lib/psmile/src/mod\_prism\_proto.F90} and by recompiling
+Oasis3 and the PSMILe library.}
+ \item {\tt ig\_paral(5)} = the global extent in X.
+\end{itemize}
+
+Figure \ref{box_partition} illustrates a Box partition over 3
+processes.  
+ 
+\begin{figure}
+\includegraphics[scale=.6]{box_new.eps} 
+\caption{Box partition}
+\label{box_partition}
+\end{figure} 
+  
+\subsection{Orange partition}
+
+Each partition is an ensemble of segments of the global domain. Each
+segment is described by its global offset and its local extent.  In
+this case, we have {\tt ig\_paral(1:N)} where {\tt N = 2 + 2*number of
+segments}\footnote{As for the Box partition, the maximum number of
+segments is presently 338; it can be increased by modifying the value
+of {\tt Clim\_MaxSegments}}.
+
+\begin{itemize}
+ \item {\tt ig\_paral(1)} = 3 (indicates a Orange partition)
+ \item {\tt ig\_paral(2)} = the total number of segments for the partition (limited to 200 presently, see note for ig\_paral(4) for Box partition above)
+ \item {\tt ig\_paral(3)} = the first segment global offset
+ \item {\tt ig\_paral(4)} = the first segment local extent
+ \item {\tt ig\_paral(5)} = the second segment global offset
+ \item {\tt ig\_paral(6)} = the second segment local extent
+ \item ...
+ \item {\tt ig\_paral(N-1)} = the last segment global offset
+ \item {\tt ig\_paral(N)} = the last segment local extent
+\end{itemize}
+
+Figure \ref{orange_partition} illustrates an Orange partition with 3 segments
+for one process. The other process partitions are not illustrated.
+
+\begin{figure}
+\includegraphics[scale=.6]{orange_new.eps} 
+\caption{Orange partition for one process}
+\label{orange_partition}
+\end{figure} 
+
+%{Partition definition}
+
+\section{I/O-coupling field declaration}
+ \label{subsubsec_Declaration}
+
+Each process implied in the coupling declares each field it will send
+or receive during the simulation. 
+
+\begin{itemize}
+
+\item {\tt CALL prism\_def\_var\_proto(var\_id, name, il\_part\_id,
+  var\_nodims, kinout, var\_actual\_shape, var\_type, ierror)}
+
+\begin{itemize}
+ \item {\tt var\_id [INTEGER; OUT]}: coupling field ID
+ \item {\tt name [CHARACTER*8; IN]}: field symbolic name (as in the
+   {\it namcouple})
+ \item {\tt il\_part\_id [INTEGER; IN]}: partition ID (returned by
+   {\tt prism\_def\_partition\-\_proto})
+ \item {\tt var\_nodims [INTEGER, DIMENSION(2); IN]}: var\_nodims(1) is
+   the rank of field array (1 or 2); var\_nodims(2) is the number of
+   bundles (always 1 for OASIS3). 
+ \item {\tt kinout [INTEGER; IN]}: {\tt PRISM\_In} for fields received by
+   the model, or {\tt PRISM\_Out} for fields sent by the model 
+ \item {\tt var\_actual\_shape [INTEGER, DIMENSION(2*var\_nodims(1)); IN]}: 
+   vector of integers giving the minimum and maximum index for each
+   dimension of the coupling field array; for OASIS3, the minimum
+   index has to be 1 and the maximum index has to be the extent of the
+   dimension.
+ \item {\tt var\_type [INTEGER; IN]}: type of coupling field array;
+   put {\tt PRISM\_Real} for single or double precision real
+   arrays\footnote{PRISM standard is to exchange coupling fields
+   declared {\tt REAL(kind=SELECTED\_REAL\_KIND(12,307))}. By default,
+   all real variables are declared as such in OASIS3. To exchange
+   single precision coupling fields, OASIS3 has to be compiled with
+   the pre-compiling key use\_realtype\_single, the coupling fields
+   must be declared {\tt REAL(kind=SELECTED\_REAL\_KIND(6,37))} in the
+   component models}. No automatic conversion is implemented;
+   therefore, all coupling fields exchanged through OASIS3 main
+   process must be of same type\footnote{Coupling fields exchanged
+   directly between two component models can have a type different
+   from the ones exchanged through OASIS3 main process, as long as
+   they are single or double precision real arrays in both models.}.
+ \item {\tt ierror [INTEGER; OUT]}: returned error code. 
+\end{itemize}
+\end{itemize}
+%{I/O-coupling field declaration}
+
+\section{End of definition phase}
+\label{subsubsec_Endofdefinition}
+Each process implied in the coupling closes the definition phase.
+\begin{itemize}
+\item {\tt CALL prism\_enddef\_proto(ierror)}
+\begin{itemize}
+  \item ierror [INTEGER; OUT]: returned error code.
+\end{itemize}
+\end{itemize}
+
+%{End of definition phase}
+
+\section{Sending and receiving actions}
+\label{subsubsec_sendingreceiving}
+
+\subsection{Sending a coupling field}
+\label{prismput}
+
+In the model time stepping loop, each process implied in the coupling
+sends its part of the I/O or coupling field. 
+
+\begin{itemize} 
+\item {\tt USE  mod\_prism\_put\_proto}
+
+Module to be used by the component model to call {\tt
+  prism\_put\_proto}.
+ 
+\item {\tt CALL prism\_put\_proto(var\_id, date, field\_array, info)}
+\begin{itemize}
+\item {\tt var\_id [INTEGER; IN]}: field ID (from
+  corresponding prism\_def\_var\_proto)
+\item {\tt date [INTEGER; IN]}: number of seconds in the run at the
+beginning of the timestep
+\item {\tt field\_array [REAL, IN]}: I/O or coupling field array 
+\item {\tt info [INTEGER; OUT]}: returned info code i.e.
+   \begin{itemize} 
+      \item PRISM\_Sent(=4) if the field was sent to another model 
+      (directly or via OASIS3 main process)
+      \item PRISM\_LocTrans (=5) if the field was only used in a time
+       transformation (not sent, not output)
+      \item PRISM\_ToRest (=6) if the field was written to a restart file only
+      \item PRISM\_Output (=7) if the field was written to an output file only
+      \item PRISM\_SentOut (=8) if the field was both written to an output file
+       and sent to another model (directly or via OASIS3 main process)
+      \item PRISM\_ToRestOut (=9) if the field was written both to a
+       restart file and to an output file.
+      \item PRISM\_Ok (=0) otherwise and no error occurred.
+   \end{itemize}
+\end{itemize}
+\end{itemize}
+
+This routine may be called by the model at each timestep. The sending
+is actually performed only if the time obtained by adding the field
+lag (see \ref{subsubsec_Algoritms}) to the argument {\tt date}
+corresponds to a time at which it should be activated, given the
+coupling or I/O period indicated by the user in the namcouple (see
+section \ref{sec_namcouple}). A field will not be sent at all if its
+coupling or I/O period indicated in the {\it namcouple} is greater
+than the total run time.
+
+If a local time transformation is indicated for the field by
+the user in the namcouple (INSTANT, AVERAGE, ACCUMUL, T\_MIN or T\_MAX,
+see section \ref{sec_transformations}), it is automatically performed
+and the resulting field is finally sent at the coupling or I/O
+frequency.
+
+For a coupling field with a positive lag (see
+\ref{subsubsec_Algoritms}), the OASIS3 restart file (see section
+\ref{subsec_restartdata}) is automatically written by the
+last {\tt prism\_put\_proto} call of the run, if its argument {\tt date}
++ the field lag corresponds to a coupling or I/O period. To
+force the writing of the field in its coupling restart file, one can
+use {\tt prism\_put\_restart\_proto} (see below).
+
+This routine can use the buffered MPI\_BSend (by default) or the
+standard blocking send MPI\_Send (if {\tt NOBSEND} is specified in the
+namcouple -see {\tt \$CHANNEL} section
+\ref{subsec_namcouplefirst}) to send the coupling fields.
+
+\vspace*{0.5cm}
+
+\subsection{Receiving a coupling field}
+
+\vspace*{0.5cm}
+
+In the model time stepping loop, each process implied in the coupling
+receives its part of the I/O-coupling field. 
+
+\begin{itemize} 
+\item {\tt USE  mod\_prism\_get\_proto}
+
+Module to be used by the component model to call {\tt
+  prism\_get\_proto}.
+\item {\tt CALL prism\_get\_proto(var\_id, date, field\_array, ierror)}
+\begin{itemize}
+\item {\tt var\_id [INTEGER; IN]}: field ID (from
+  corresponding prism\_def\_var\_proto)
+\item {\tt date [INTEGER; IN]}: number of seconds in the run at the
+beginning of the timestep
+\item {\tt field\_array [REAL, OUT]}: I/O or coupling field array 
+\item {\tt info [INTEGER; OUT]}: returned info code
+   \begin{itemize} 
+      \item PRISM\_Recvd(=3) if the field was received from another model
+       (directly or via OASIS3 main process)
+      \item PRISM\_FromRest (=10) if the field was read from a restart
+       file only (directly or via OASIS3 main process)
+      \item PRISM\_Input (=11) if the field was read from an input
+       file only
+      \item PRISM\_RecvOut (=12) if the field was both received from
+       another model (directly or via OASIS3 main process) and written to
+       an output file
+      \item PRISM\_FromRestOut (=13) if the field was both read from a
+       restart file (directly or via OASIS3 main process) and written to an
+       output file
+      \item PRISM\_Ok (=0) otherwise and no error occurred.
+   \end{itemize}
+\end{itemize}
+\end{itemize}
+
+This routine may be called by the model at each timestep. The {\tt date}
+argument is automatically analysed and the receiving action is actually
+performed only if {\tt date} corresponds to a time for which it should
+be activated, given the period indicated by the user in the
+namcouple. A field will not be received at all if its
+coupling or I/O period indicated in the {\it namcouple} is greater
+than the total run time.
+
+\subsection{Auxiliary routines}
+\label{subsec:auxiliary}
+\begin{itemize} 
+\item {\tt CALL prism\_put\_inquire(var\_id, date, info)}
+\begin{itemize}
+\item {\tt var\_id [INTEGER; IN]}: field ID (from
+  corresponding prism\_def\_var\_proto)
+\item {\tt date [INTEGER; IN]}: number of seconds in the run at the
+beginning of the timestep 
+\item {\tt info [INTEGER; OUT]}: returned info code. 
+\end{itemize}
+\end{itemize}
+
+This routine may be called at any time to
+inquire what would happen to the corresponding field (i.e. with same
+{\tt var\_id} and at same {\tt date}) below the corresponding {\tt
+  prism\_put\_proto}. The possible value of the returned info code are
+as for {\tt prism\_put\_proto}:   
+\begin{itemize}
+      \item PRISM\_Sent(=4) if the field would be sent to another model 
+      (directly or via OASIS3 main process)
+      \item PRISM\_LocTrans (=5) if the field would be only used in a time
+       transformation (not sent, not output)
+      \item PRISM\_ToRest (=6) if the field would be written to a restart file only
+      \item PRISM\_Output (=7) if the field would be written to an output file only
+      \item PRISM\_SentOut (=8) if the field would be both written to an output file
+       and sent to another model (directly or via OASIS3 main process)
+      \item PRISM\_ToRestOut (=9) if the field would be written both to a
+       restart file and to an output file.
+      \item PRISM\_Ok (=0) otherwise and no error occurred. 
+\end{itemize}
+This is useful when the
+calculation of the corresponding {\tt field\_array} is CPU consuming
+and should be avoided if the field is not effectively used below the {\tt
+prism\_put\_proto}.
+
+\begin{itemize} 
+\item {\tt CALL prism\_put\_restart\_proto(var\_id, date, ierror)}
+\begin{itemize}
+\item {\tt var\_id [INTEGER; IN]}: field ID (from
+  corresponding prism\_def\_var\_proto)
+\item {\tt date [INTEGER; IN]}: number of seconds in the run at the
+beginning of the timestep
+\item {\tt info [INTEGER; OUT]}: returned error code (should be
+  PRISM\_ToRest=6 if the restart writing was successful)
+\end{itemize}
+\end{itemize}
+
+This routine forces the writing of the field with corresponding {\tt
+var\_id} in its coupling restart file (see section
+\ref{subsec_restartdata}). If a time operation is specified for this
+field, the value of the field as calculated below the last {\tt
+prism\_put\_proto} is written. If no time operation is specified, the
+value of the field transferred to the last {\tt prism\_put\_proto} is
+written.
+
+%{sending and receiving actions}
+
+\section{Termination}
+\label{subsubsec_Termination}
+
+\begin{itemize}
+
+\item {\tt CALL prism\_terminate\_proto(ierror)}
+  \begin{itemize}
+  \item {\tt ierror [INTEGER; OUT]}: returned error code.
+  \end{itemize}
+  Each process must terminate the coupling by calling {\tt
+  prism\_terminate\_proto}\footnote{If the process called {\tt
+  MPI\_Init} (before calling {\tt prism\_init\_comp\_proto}), it must
+  also call {\tt MPI\_Finalize} explicitly, but only after calling
+  {\tt prism\_terminate\_proto}.} (normal termination). Oasis will
+  terminate after all processes implied in the coupling call
+  prism\_terminate\_proto. With MPI2, the run may be considered
+  finished when Oasis terminates; to avoid problem, place the call
+  to prism\_terminate\_proto at the very end in the component model code.
+
+\item {\tt CALL prism\_abort\_proto(compid, routine\_name, abort\_message)}
+\begin{itemize}
+  \item {\tt compid [INTEGER; IN]}: component model ID (from
+prism\_init\_comp\_proto) 
+  \item {\tt routine\_name; IN]}: name of calling routine
+  \item {\tt abort\_message; IN]}: message to be written out.
+\end{itemize}
+
+ If a process needs to abort (abnormal termination), it must do so by
+ calling {\tt prism\_abort\_proto}. This will ensure a proper
+ termination of all processes in the coupled model communicator. This
+ routine writes the name of the calling model, the name of the
+ calling routine, and the message to the job standard output (stdout).
+
+\end{itemize}
+
+%{Termination}
+
+\section{Coupling algorithms - SEQ and LAG concepts}
+\label{subsubsec_Algoritms}
+
+Using PSMILe library, the user has full flexibility to reproduce
+different coupling algorithms, without modifying the component model
+codes themselves. In the component codes, the sending and receiving
+routines, respectively {\tt prism\_put\_proto} and {\tt
+prism\_get\_proto}, can be called at each model timestep, with the
+appropriate {\tt date} argument giving the actual time (at the
+beginning of the timestep), expressed in ``number of seconds since the
+start of the run''. This {\tt date} argument is automatically analysed
+by the PSMILe\footnote{With the PIPE, SIPC, GMEM and previously with
+the CLIM communication techniques, no such analysis was performed. For
+PIPE, SIPC, and GMEM, the sending actions on the source side would
+automatically match the receiving actions on the target side on a FIFO
+(First In First Out) basis.} and depending on the coupling period, the
+lag and sequencing indices (LAG and SEQ), chosen by the user for each
+coupling field in the configuration file {\it namcouple}, different
+coupling algorithms can be reproduced {\bf without modifying anything in the
+component model codes themselves.}  The lag and sequence concepts and
+indices are explained in more details here below. These mechanisms
+are valid for fields exchanged through OASIS3 main
+process and for fields exchanged directly between the component
+models.
+
+\subsection{The lag concept}
+\label{subsub_lag}
+
+If no lag index or if a lag index equal to 0 is given by the user in
+the {\it namcouple} for a particular coupling field, the sending or
+receiving actions will actually be performed, below the {\tt
+  prism\_put\_proto} called in the source model or below the {\tt
+  prism\_get\_proto} called in the target model respectively, each time the
+{\tt date} arguments on both sides match an integer number of
+coupling periods.
+ 
+\vspace*{0.5cm}
+
+To match a {\tt prism\_put\_proto} called by the source model at a
+particular date with a {\tt prism\_get\_proto} called by the target
+model at a different date, the user has to define in the {\it
+namcouple} an appropriate lag index, LAG, for the coupling field(see
+section \ref{sec_namcouple}). The value of the LAG index must be
+expressed in ``number of seconds''; its value is automatically added
+to the {\tt prism\_put\_proto} date value and the sending action is
+effectively performed when the sum of the date and the lag matches an
+integer number of coupling periods. This sending action is
+automatically matched, on the target side, with the receiving action
+performed when the {\tt prism\_get\_proto} date argument equals the
+same integer number of coupling periods.
+ 
+  \begin{enumerate}
+
+  \item LAG concept first example
+ 
+  A first coupling algorithm, exploiting the LAG concept, is
+  illustrated on figure \ref{fig:lag_concept_1}. 
+
+
+  On the 4 figures in this section, short black arrows correspond to {\tt
+  prism\_put\_proto} or \break {\tt prism\_get\_proto} called in the component model
+  that do not lead to any sending or receiving action;
+  long black arrows correspond to {\tt prism\_put\_proto} or {\tt
+  prism\_get\_proto} called in the component models that do
+  effectively lead to a sending or receiving action;
+  long red arrows correspond to {\tt prism\_put\_proto} or {\tt
+  prism\_get\_proto} called in the component models that lead to a
+  reading or writing of the coupling field from or to a coupling
+  restart file (either directly or through OASIS3 main process).
+
+\begin{figure}
+\includegraphics[scale=.6]{fig_lag_concept_1.eps}
+\caption{LAG concept first example} 
+\label{fig:lag_concept_1}
+\end{figure}
+
+  During a coupling timestep, model A receives $F_2$ and then sends $F_1$; its
+  timestep length is 4. During a coupling timestep, model B receives $F_1$
+  and then sends $F_2$; its timestep length is 6.  $F_1$ and $F_2$
+  coupling periods are respectively 12 and 24. If $F_1$/$F_2$ sending
+  action by model A/B was used at a coupling timestep to match the
+  model B/A receiving action, a deadlock would occur as both models
+  would be initially waiting on a receiving action. To prevent this,
+  $F_1$ and $F_2$ produced at the timestep before have to be used to
+  match respectively the model B and model A receiving actions.
+
+  This implies that a lag of respectively 4 and 6 seconds must be
+  defined for $F_1$ and $F_2$. For $F_1$, the {\tt prism\_put\_proto}
+  performed at time 8 and 20 by model A will then lead to sending actions
+  (as 8 + 4 = 12 and 20 + 4 = 24 which are coupling periods) that
+  match the receiving actions performed at times 12 and 24 below the {\tt
+  prism\_get\_proto} called by model B.  For $F_2$, the {\tt
+  prism\_put\_proto} performed at time 18 by model B then leads to
+  a sending action (as 18 + 6 = 24 which is a coupling
+  period) that matches the receiving action performed at time 24
+  below the {\tt prism\_get\_proto} called by model A.
+
+  At the beginning of the run, as their LAG index is greater than 0,
+  the first {\tt prism\_get\_proto} will automatically lead to reading
+  $F_1$ and $F_2$ from their coupling restart files. The user
+  therefore have to create those coupling restart files for the first
+  run in the experiment. At the end of the run, $F_1$
+  having a lag greater than 0, is automatically written to its
+  coupling restart file below the last $F_1$ {\tt prism\_put\_proto} if the
+  {\tt date} + $F_1$ lag equals a coupling time. The analogue is true
+  for $F_2$. These
+  values will automatically be read in at the beginning of the next
+  run below the respective {\tt prism\_get\_proto}.
+
+  \item LAG concept second example
+
+  A second coupling algorithm exploiting the LAG concept is
+  illustrated on figure \ref{fig:lag_concept_2}. During its timestep,
+  model A receives $F_2$, sends $F_3$ and then $F_1$; its timestep
+  length is 6. During its timestep, model B receives $F_1$, receives
+  $F_3$ and then sends $F_2$; its timestep length is also 6.  $F_1$,
+  $F_2$ and $F_3$ coupling periods are both supposed to be equal to
+  12.
+ 
+\begin{figure}
+\includegraphics[scale=.6]{fig_lag_concept_2.eps} 
+\caption{LAG concept second example} 
+\label{fig:lag_concept_2}
+\end{figure}
+
+  For $F_1$ and $F_2$ the situation is similar to the first
+  example. If $F_1$/$F_2$ sending action by model A/B was used at a
+  coupling timestep to match the model B/A receiving action, a
+  deadlock would occur as both models would be waiting on a receiving
+  action. To prevent this, $F_1$ and $F_2$ produced at the timestep
+  before have to be used to match the model A and model B receiving
+  actions, which means that a lag of 6 must be defined for both $F_1$
+  and $F_2$. For both coupling fields, the {\tt prism\_put\_proto}
+  performed at times 6 and 18 by the source model then lead to sending
+  actions (as 6 + 6 = 12 and 18 + 6 = 24 which are coupling periods)
+  that match the receiving action performed at time 12 and 24 below
+  the {\tt prism\_get\_proto} called by the target model.
+
+  For $F_3$, sent by model A and received by model B, no lag
+  needs to be defined: the coupling field produced by model A at the
+  coupling timestep can be ``consumed'' by model B without causing a
+  deadlock situation.
+
+  As in the first example, the {\tt prism\_get\_proto} performed at
+  the beginning of the run for $F_1$ and $F_2$, automatically read
+  them from their coupling restart files, and the last {\tt
+  prism\_put\_proto} performed at the end of the run automatically
+  write them to their coupling restart file. For $F_3$, no coupling
+  restart file is needed nor used as at each coupling period the
+  coupling field produced by model A can be directly ``consumed'' by
+  model B.
+
+  We see here how the introduction of appropriate LAG indices results in
+  receiving, below the \break {\tt prism\_get\_proto} in the target model,
+  coupling fields produced, below the {\tt prism\_put\_proto} by the
+  source model, the timestep before; this is, in some coupling
+  configurations, essential to avoid deadlock situations.
+
+  \end{enumerate}
+
+\subsection{The sequence concept}
+ 
+To exchange the coupling fields going through OASIS3 main process
+(i.e. with status EXPORTED, AUXILARY, or EXPOUT, see section
+\ref{sec_namcouple}), in a given order at each coupling timestep, a
+sequence index SEQ must be defined for each of them. This is not
+required for I/O fields or for coupling fields exchanged directly
+between the component models, i.e. with status IGNOUT, INPUT or
+OUTPUT. SEQ gives the position of the coupling field in the
+sequence.
+
+\begin{figure}
+\includegraphics[scale=.6]{fig_seq_concept.eps} 
+\caption{The SEQ concept}
+\label{fig:seq_concept}
+\end{figure}
+
+A coupling algorithm, showing the SEQ concept, is illustrated on
+figure \ref{fig:seq_concept}. All coupling field produced by the
+source model at the coupling timestep can be ``consumed'' by the
+target model at the same timestep without causing any
+deadlock situation; therefore, LAG = 0 for all coupling fields.
+However, at each coupling timestep, a particular order
+of exchange must be respected; $F_1$ must be received by
+model A before it can send $F_2$, which in turn must be received by model B
+before it can send $F_3$. Therefore, SEQ = 1, 2, 3 must be defined
+respectively for $F_1$, $F_2$ and $F_3$. 
+As all fields can be consumed at the time they are produced (LAG=0 for
+all fields), there no reading/writing from/to coupling restart files.
+
+\subsection{A mix of lag and sequence: the sequential coupled model}
+\label{subsubsec_mix}
+
+One can run the same component models simultaneously or sequentially
+by defining the appropriate LAG and SEQ indices. In the example
+illustrated on figure \ref{fig:mix_seqlag}, the models perform their
+{\tt prism\_put\_proto} and {\tt prism\_get\_proto} calls exactly as
+in the first lag example above: model A receives $F_2$ and then sends
+$F_1$; its timestep length is 4. During a coupling timestep, model B
+receives $F_1$ and then sends $F_2$; its timestep length is 6.  $F_1$
+and $F_2$ coupling periods are both 12. By defining a LAG index of -8
+for $F_1$, the models will now run sequentially.
+
+\begin{figure}
+\includegraphics[scale=.6]{fig_mix_seqlag.eps}
+\caption{Mix of LAF and SEQ concepts}
+\label{fig:mix_seqlag}
+\end{figure}
+
+As the LAG for $F_2$ is positive (6), a reading of $F_2$ in its
+coupling restart file is automatically performed below the initial
+{\tt prism\_get\_proto}. As the LAG for $F_1$ is negative (-8), no
+reading from file is performed initially and model B waits; at time 8,
+a sending action is effectively performed below model A $F_1$ {\tt
+prism\_put\_proto} (as 8 + LAG (-8) = 0 which is the first coupling
+timestep) and matches the initial model B $F_1$ {\tt
+prism\_get\_proto}. Below the last model A $F_1$ {\tt
+prism\_put\_proto} of the run at time 116, a sending action is
+effectively performed, as $116 + LAG(-8) = 108$ is a coupling period
+(as the LAG is negative, the field is not written to its coupling
+restart file). Below the last model B $F_2$ {\tt prism\_put\_proto} of
+the run at time 114, a writing of $F_2$ to its restart file is
+performed, as $114 + LAG(6) = 120$ is a coupling period and as the LAG
+is positive.
+
+If the coupling fields are transformed through OASIS3 main process, it
+is important to indicate a sequence index. In fact, at each OASIS3
+main process coupling timestep, $F_1$ is necessarily treated after
+$F_2$. Therefore, $SEQ(F_1) = 2$ and $SEQ(F_2) = 1$.
+
+\subsection{Mixing sequential and parallel
+    runs using {\tt prism\_put\_restart\_proto}}
+
+In the example illustrated on figure \ref{restart_ex}, the models
+run sequentially for the first run only and then run
+simultaneously. For the first run, the LAG and SEQ indices must be
+defined as in section \ref{subsubsec_mix}.  After the first run, the
+situation is similar to the one of section \ref{subsub_lag}, and
+positive LAG must be defined for $F_1$ and $F_2$. As their lag is
+positive, their corresponding first {\tt prism\_get\_proto} will
+automatically lead to reading $F_1$ and $F_2$ from coupling restart
+files.  In this case, model A has to write $F_1$ to its restart file
+explicitly by calling {\tt prism\_put\_restart\_proto} (illustrated
+on the figure by an orange arrow) at the end of the first run; in
+fact, $F_1$ lag being then negative, such writing is not automatically
+done below the last {\tt prism\_put\_proto} of the first run.
+
+
+\begin{figure}
+\includegraphics[scale=.6]{restart_example.eps} 
+\caption{An example using prism\_put\_restart\_proto}
+\label{restart_ex}
+\end{figure} 
+
+%section{PRISM System Model Interface for the CLIM/MPI2-MPI1
+%communication technique (PSMILe V.0)}
+%section{Model\_interfacing} 
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG3_Namcouple_generation.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG3_Namcouple_generation.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG3_Namcouple_generation.tex	(revision 1677)
@@ -0,0 +1,453 @@
+\newpage
+\chapter{The OASIS3 configuration file {\it namcouple}}
+\label{sec_namcouple}
+
+The OASIS3 configuration file {\em namcouple} contains, below
+pre-defined keywords, all user's
+defined information necessary to configure a particular coupled
+run. The {\it namcouple} is a text file with the following
+characteristics:
+
+\begin{itemize}
+\item the keywords used to separate the information
+can appear in any order;
+\item the number of blanks between two character strings is
+non-significant; 
+\item all lines beginning with \# are ignored and considered as
+comments.
+\item {\bf blank lines are not allowed.}
+\end{itemize}
+\vspace*{0.5cm}
+
+The first part of {\em namcouple } is devoted to configuration of
+general parameters such as the number of models involved in the
+simulation, the number of fields, the communication technique, etc.
+The second part gathers specific information on each coupling or I/O
+field, e.g. their coupling period, the list of transformations or
+interpolations to be performed by OASIS3 and their associated
+configuring lines (described in more details in section
+\ref{sec_transformations}), etc.
+
+\vspace*{0.5cm}
+
+In the next sections, a simple {\it namcouple} example is given and
+all configuring parameters are described. The additional lines
+containing the different parameters required for each transformation
+are described in section \ref{sec_transformations}. An example of a
+realistic {\em namcouple} can be found in directory {\tt
+/prism/util/running\break/adjunct\_files/oasis3/namcouple\_toyclim\_use}.
+
+\section{An example of a simple {\it namcouple}}
+\label{subsec_examplenamcouple}
+
+The following simple {\it namcouple} configures a run in which an
+ocean, an atmosphere and an atmospheric chemistry models are
+coupled. The ocean provides only the SOSSTSST field to the atmosphere,
+which in return provides the field CONSFTOT to the ocean. One field
+(COSENHFL) is exchanged directly from the atmosphere to the
+atmospheric chemistry, and one field (SOALBEDO) is read from a file by
+the ocean.
+
+\begin{verbatim}
+
+######################################################################
+# First section
+#
+ $SEQMODE
+    1
+#
+ $CHANNEL
+    MPI2    NOBSEND
+    1    1   arg1
+    3    1   arg2
+    3    1   arg3            
+#
+ $NFIELDS
+    4
+#
+ $JOBNAME
+    JOB
+#
+ $NBMODEL
+    3  ocemod   atmmod  chemod  55  70   99 
+#
+ $RUNTIME
+    432000
+#
+ $INIDATE
+    00010101
+#
+ $MODINFO
+    NOT
+#
+ $NLOGPRT
+   2
+#
+ $CALTYPE
+   1
+#
+######################################################################
+# Second section 
+#
+ $STRINGS
+#
+# Field 1
+#
+ SOSSTSST SISUTESU 1 86400  5  sstoc.nc  EXPORTED
+ 182  149  128  64  toce  atmo   LAG=+14400  SEQ=+1
+ P 2 P 0
+ LOCTRANS CHECKIN MOZAIC  BLASNEW CHECKOUT 
+#
+  AVERAGE 
+  INT=1
+  at31topa   91    2   48
+  CONSTANT     273.15 
+  INT=1
+#
+# Field 2
+#
+ CONSFTOT SOHEFLDO 6 86400  7   flxat.nc  EXPORTED
+ atmo   toce  LAG=+14400  SEQ=+1
+ P 0 P 2
+ LOCTRANS  CHECKIN  SCRIPR CHECKOUT
+#
+  ACCUMUL 
+  INT=1
+  CONSERV  LR  SCALAR  LATLON   10  FRACAREA   FIRST
+  INT=1
+#
+# Field 
+#
+ COSENHFL  SOSENHFL  37  86400   1  flda3.nc  IGNOUT 
+ atmo   atmo LAG=+7200  SEQ=+1
+ LOCTRANS
+ AVERAGE
+#
+# Field 4
+#
+ SOALBEDO SOALBEDO  17  86400  0  SOALBEDO.nc  INPUT
+#
+#####################################################################
+\end{verbatim}
+
+%section{An example of a simple {\em namcouple}}
+
+\section{ First section of {\it namcouple} file}
+\label{subsec_namcouplefirst}
+
+The first section of {\it namcouple } uses some predefined keywords
+prefixed by the \$ sign to locate the related information. The
+\$ sign must be in the second column. The first ten keywords
+are described hereafter:
+
+\begin{itemize}
+
+\item {\tt \$SEQMODE}: On the line below this keyword is the maximum number of fields that
+  have to be, at one particular coupling timestep,
+  necessarily exchanged sequentially in a given order.  For {\tt
+  \$SEQMODE} $\ge 1$, the position of each coupling field in the sequence has to be
+  given by its SEQ index (see below and also section
+  \ref{subsubsec_Algoritms}).
+
+\item {\tt \$CHANNEL}: On the line below this keyword is the
+communication technique chosen. Choices are {\tt MPI1} or {\tt MPI2}
+for the CLIM communication technique and related PSMILe library, using
+{\tt MPI1} or {\tt MPI2} message passing.  To run OASIS3 as an
+interpolator only, put {\tt NONE} (see also section
+\ref{subsec_interpolator}). The communication technique using Unix
+System V Shared Memory Segments, {\tt SIPC}, is also
+supported. {\tt PIPE}, or {\tt GMEM} should still work but are not
+officially supported anymore and were not tested (corresponding
+sources can be retrieved from CERFACS CVS Server only).
+
+To use the {\tt CLIM/MPI2} communication technique, the lines below {\tt
+  \$CHANNEL} are, e.g. for 3 models:
+\begin{verbatim} 
+$CHANNEL 
+MPI2 NOBSEND
+1    1  arg1 
+3    1  arg2
+3    1  arg3 
+\end{verbatim}
+where {\tt MPI2} is the message passing used in CLIM and PSMILe, and
+{\tt NOBSEND} indicates that standard blocking send {\tt MPI\_Send}
+should be used in place of the buffered {\tt MPI\_BSend} to send the
+coupling fields.\footnote{Use the standard blocking send {\tt
+MPI\_Send} if the coupling fields are necessarily sent and received in
+the same order, or on platforms for which {\tt MPI\_Send} is
+implemented with a mailbox (e.g. VPPs; in this case, make sure
+that the size of the mailbox is sufficient). Use the less efficient
+buffered send {\tt MPI\_BSend} on platforms for which {\tt
+MPI\_Send} is not implemented with a mailbox if the
+coupling fields are not sent and received in the same order.
+
+Note that below the call to {\tt prism\_enddef\_proto}, the PSMILe
+tests whether or not the model has already attached to an MPI
+buffer. If it is the case, the PSMILe detaches from the buffer, adds
+the size of the pre-attached buffer to the size needed for the
+coupling exchanges, and reattaches to an MPI buffer. The model own
+call to {\tt MPI\_Buffer\_Attach} must therefore be done before the
+call to {\tt prism\_enddef\_proto}. Furthermore, the model is not
+allowed to call {\tt MPI\_BSend} after the call to {\tt
+prism\_terminate\_proto}, as the PSMILe definitively detaches from the
+MPI buffer in this routine. See the example in the toyatm model in
+{\tt prism/src/mod/toyatm/src} }
+
+If {\tt NOBSEND} is not specified, the buffered send {\tt MPI\_BSend}
+will be used.
+
+The following lines (one line per model listed on the {\tt \$NBMODEL}
+line) indicate for each model the total number of processes, the
+number of processes implied in the coupling, and possibly launching
+arguments. Here the first model runs on one process which is of course
+implied in the coupling and the argument passed to the model is
+"arg1"; the second and third models run on 3 processes but only one
+process is implied in the coupling (i.e. exchanging information with
+OASIS3 main process), and the argument passed to the models are
+respectively ``arg2" and ``arg3''.
+
+To use the {\tt CLIM/MPI1} communication technique, the {\tt
+\$CHANNEL} lines are are as for {\tt MPI2} except that {\tt MPI2} is
+replaced by {\tt MPI1} and there is no launching arguments.  gument.
+
+To use the {\tt SIPC} communication technique, the user has to write
+only {\tt SIPC} below the {\tt \$CHANNEL} keyword (corresponding
+sources can be retrieved from CERFACS CVS Server only).
+
+\item {\tt \$NFIELDS}: On the line below this keyword is the total
+number of fields exchanged and described in the second part of
+the {\it namcouple}.
+
+\item {\tt \$JOBNAME}: On the line below this keyword is a {\tt
+CHARACTER$\star$3} or {\tt CHARACTER$\star$4} variable giving an
+acronym for the given simulation.
+
+\item {\tt \$NBMODEL}: On the line below this keyword is the number of
+models running in the given experiment followed by {\tt
+CHARACTER$\star$6} variables giving their names. Then the user may
+indicate the maximum Fortran unit number used by the models. In the
+example, Fortran units above 55, 70, and 99 are free for respectively
+the ocean, atmosphere, and atmospheric chemistry models. If no
+maximum unit numbers are indicated, OASIS3 will suppose that units
+above 1024 are free. If {\tt \$CHANNEL}
+is {\tt NONE}, {\tt \$NBMODEL} has to be 0 and there should be no
+model name and no unit number.
+
+\item {\tt \$RUNTIME}: On the line below this keyword is the total
+simulated time of the run, expressed in seconds. If {\tt \$CHANNEL}
+is {\tt NONE}, {\tt \$RUNTIME} has to be the number of time occurrences
+of the field to interpolate from the restart file. 
+
+\item {\tt \$INIDATE}: On the line below this keyword is the initial
+  date of the run. The format is {\tt YYYYMMDD}. This date is important only
+  for the {\tt FILLING} transformation and for printing information in
+  OASIS3 log file {\it cplout}.
+
+\item {\tt \$MODINFO}: If coupling restart files are binary files (see
+  section \ref{subsec_restartdata}), the line below this keyword
+  indicates if a header is encapsulated or not: it can be {\tt
+  YES} or {\tt NOT}.
+ 
+\item {\tt \$NLOGPRT}: The line below this keyword refers to the
+  amount of information that will be written to the OASIS3 log file
+  {\it cplout} during the run. With 0, there is practically no output
+  written to the cplout; with 1, only some general information on the
+  run, the header of the main routines, and the names of the fields
+  when treated appear in the {\it cplout}.  Finally, with 2, the full output
+  is generated.
+
+\item {\tt \$CALTYPE}: This new keyword gives the type of calendar
+  used. For now, the calendar type is important only if {\tt FILLING}
+  analysis is used for a coupling field in the run and for printing
+  information in OASIS3 log file {\it cplout}. Below this keyword, a
+  number (0, 1 or n ) must be indicated by the user:
+  \begin{itemize}
+  \item 0 : a 365 day calendar (no leap year) 
+  \item 1 : a 365 or 366 (leap years) day calendar A year is a leap
+  year if it can be divided by 4; however if it can be divided by 4
+  and 100, it is not a leap year; furthermore, if it can be divided by
+  4, 100 and 400, it is a leap year.
+  \item n :  $n \ge 1$ day month calendar. 
+  \end{itemize}
+
+\end{itemize}
+
+%{Description of {\it namcouple} first section}
+
+\section{Second section of {\it namcouple} file }
+\label{subsec_namcouplesecond}
+
+The second part of the {\it namcouple}, starting after the keyword
+{\tt \$STRINGS}, contains coupling information for each coupling or
+I/O field.  Its format depends on the field status given by the last
+entry on the field first line ({\tt EXPORTED}, {\tt IGNOUT} or {\tt
+INPUT} in the example above). The field status may be the following
+({\tt AUXILARY} and {\tt EXPORTED} are supported by all communication
+techniques, while the others are supported only by the PSMILe i.e. the
+{\tt CLIM/MPI1} or {\tt CLIM/MPI2} communication technique):
+
+\begin{itemize}
+\item {\tt AUXILARY}: sent by the source model, received and used by
+  OASIS3 main process for the transformation of other fields.
+\item {\tt EXPORTED}: exchanged between component models and
+  transformed by OASIS3 main process.
+\item {\tt EXPOUT}: exchanged, transformed and also written to two
+  output files, one before the sending action in the source model
+  below the {\tt prism\_put\_proto} call, and one after the receiving
+  action in the target model below the {\tt prism\_get\_proto} call.
+\item {\tt IGNORED}: exchanged directly between the component models
+  without being transformed by OASIS3 main process. The grid and
+  partitioning of the source and target models have to be
+  identical.
+\item {\tt IGNOUT}: exchanged directly between the component models
+  without being transformed by OASIS3 main process and written to two
+  output files, one before the sending action in the source model
+  below the {\tt prism\_put\_proto} call, and one after the receiving
+  action in the target model below the {\tt prism\_get\_proto} call.
+  The grid and partitioning of the source and target models have to be
+  identical.
+\item {\tt INPUT}: simply read in from the input file by the target
+  model PSMILe below the {\tt prism\_get\_proto} call at appropriate
+  times corresponding to the input period indicated by the user in the
+  {\it namcouple}. See section
+  \ref{subsec_inputdata} for the format of the input file.
+\item {\tt OUTPUT}: simply written out to an output file by the source
+  model PSMILe below the {\tt prism\_put\_proto} call at appropriate
+  times corresponding to the output period indicated by the user in
+  the {\it namcouple}. The name of the output file (one per field) is
+  automatically built based on the field name and initial date of the
+  run ({\tt \$INIDATE}).
+
+\end{itemize}
+
+\subsection{Second section of {\it namcouple} for {\tt EXPORTED}, {\tt
+      AUXILARY} and {\tt EXPOUT} fields}
+\label{subsubsec_secondEXPORTED}
+
+  The first 3 lines for fields with status {\tt EXPORTED}, {\tt
+  AUXILARY} and {\tt EXPOUT} are as follows:
+  \begin{verbatim}
+   SOSSTSST SISUTESU 1 86400  5  sstoc.nc  sstat.nc EXPORTED
+   182  149    128  64  toce  atmo   LAG=+14400 SEQ=+1
+   P 2 P 0 
+  \end{verbatim}
+  where the different entries are:
+    \begin{itemize}
+      \item Field first line:
+        \begin{itemize}
+        \item {\tt SOSSTSST} : symbolic name for the field in the
+              source model ({\tt CHARACTER*8}). It has to match the
+              argument {\tt name} of the corresponding field
+              declaration in the source model; see {\tt
+              prism\_def\_var\_proto} in section
+              \ref{subsubsec_Declaration}.
+        \item {\tt SISUTESU} : symbolic name for the field in the
+              target model ({\tt CHARACTER*8}).  It has to match the
+              argument {\tt name} of the corresponding field
+              declaration in the target model; see {\tt
+              prism\_def\_var\_proto} in section
+              \ref{subsubsec_Declaration}.
+        \item 1 : index in auxiliary file cf\_name\_table.txt used by OASIS3 and PSMILe to identify corresponding CF standard name and units (see \ref{subsec_cfnametable}).
+        \item 86400 : coupling and/or I/O period for the field, in
+        seconds. (If {\tt \$CHANNEL} is {\tt NONE}, put ``1''.)
+        \item 5 : number of transformations to be performed on this field.  
+        \item sstoc.nc : name of the coupling restart file for the
+  	  field ({\tt CHARACTER*8}); it may be a binary of netCDF file (for
+	  more detail, see section \ref{subsec_restartdata}).
+        \item sstat.nc : name of the field output file, may be indicated for
+	  {\tt NONE} (and {\tt PIPE}) communication techniques only. It
+	  may be a binary of netCDF file (see section
+	  \ref{subsec_restartdata}).
+        \item {\tt EXPORTED} : field status.
+        \end{itemize}
+      \item Field second line:
+        \begin{itemize}
+        \item 182 : number of points for the source grid first
+        dimension (optional if a netCDF coupling restart file is used). 
+        \item 149 : number of points for the source grid second
+        dimension (optional if a netCDF coupling restart file is used).    
+        \item 128 : number of points for the target grid first
+        dimension (optional if a netCDF coupling restart file is used). 
+        \item 64 : number of points for the target grid second
+        dimension (optional if a netCDF coupling restart file is used).  
+        \item toce : prefix of the source grid name in grid data files (see section
+        \ref{subsec_griddata}) ({\tt CHARACTER*4})
+        \item atmo : prefix of the target grid name in grid data files
+        ({\tt CHARACTER*4})
+        \item {\tt LAG=+14400}: lag index for the field
+        expressed in seconds ({\tt CLIM/MPI1} or {\tt CLIM/MPI2}
+        communication technique only, see section
+        \ref{subsubsec_Algoritms}). Note that in mode NONE a LAG has
+        to be defined so that the input file is opened initially.
+        \item {\tt SEQ=+1}: optional sequence index for the field
+        ({\tt CLIM/MPI1} or {\tt CLIM/MPI2} communication technique
+        only, see section \ref{subsubsec_Algoritms}).
+        \end{itemize}
+      \item Field third line
+        \begin{itemize}
+         \item P : source grid first dimension characteristic
+            (`P': periodical; `R': regional).
+         \item 2 : source grid first dimension number of overlapping grid points.
+         \item P : target grid first dimension characteristic (`P':
+         periodical; `R': regional).
+         \item 0 : target grid first dimension number of overlapping grid points.
+        \end{itemize}
+     
+      \end{itemize}
+    
+  The fourth line gives the list of transformations to be performed
+  for this field. There is then one or more additional configuring lines
+  describing some parameters for each transformation. These
+  additional lines are described in more details in the section
+  \ref{sec_transformations}.
+
+\subsection{Second section of {\it namcouple} for {\tt
+  IGNORED}, {\tt IGNOUT}, and {\tt OUTPUT} fields}
+\label{subsubsec_secondIGNORED}
+  The first 2 lines for fields with status {\tt IGNORED} or {\tt
+  IGNOUT} or {\tt OUTPUT} are as follows:
+  \begin{verbatim}
+  COSENHFL SOSENHFL 37 86400 1 flda3.nc IGNOUT 
+  atmo   toce LAG=+7200 SEQ=+1\end{verbatim}where the different
+  entries are as for {\tt EXPORTED} fields, except that there is no
+  output file name on the first line.
+
+  For {\tt OUTPUT} fields, there is no target model and therefore no
+  target symbolic name; the source symbolic name must be repeated
+  twice on the field first line. Also, there is no coupling restart
+  file name ({\tt flda3.nc} here), no {\tt LAG} index and no {\tt SEQ}
+  index.
+
+  For {\tt IGNORED} fields, the name used in the coupling restart file
+  (if any) must be the target symbolic name.
+
+\vspace*{0.5cm}
+
+  The third line is {\tt LOCTRANS} if this transformation is chosen
+  for the field. Note that {\tt LOCTRANS} is the only transformation
+  supported for {\tt IGNORED}, {\tt IGNOUT} and {\tt OUTPUT} fields
+  (as it is performed directly in the PSMILe below the {\tt
+  prism\_put\_proto} call). If {\tt LOCTRANS} is chosen, a fourth line
+  giving the name of the time transformation is required. For more
+  detail on {\tt LOCTRANS}, see section \ref{subsec_timetrans}.
+
+\subsection{Second section of {\it namcouple} for {\tt
+  INPUT} fields}
+\label{subsubsec_secondINPUT}
+
+  The first and only line for fields with status {\tt INPUT} is:
+
+  \begin{verbatim}
+  SOALBEDO SOALBEDO  17  86400  0  SOALBEDO.nc  INPUT\end{verbatim} where the different entries are:
+  \begin{itemize}
+  \item  {\tt SOALBEDO}: symbolic name for the field in the target
+  model ({\tt CHARACTER*8} repeated twice)
+  \item 17:  index in auxiliary file cf\_name\_table.txt (see above for EXPORTED fields)
+  \item 86400: input period in seconds
+  \item 0: number of transformations (always 0 for {\tt INPUT} fields)
+  \item {\tt SOALBEDO.nc}: {\tt CHARACTER*32} giving the input file
+  name (for more detail on its format, see section
+  \ref{subsec_inputdata})
+  \item {\tt INPUT}: field status.
+  \end{itemize}
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG4_Transformations.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG4_Transformations.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG4_Transformations.tex	(revision 1677)
@@ -0,0 +1,880 @@
+\newpage
+\chapter{The transformations and interpolations in OASIS3}
+\label{sec_transformations}
+
+Different transformations and 2D interpolations are available in
+OASIS3 to adapt the coupling fields from a source model grid to a target
+model grid. They are divided into five general classes that have
+precedence one over the other in the following order: time
+transformation (with {\tt CLIM/MPI1-MPI2} and PSMILe only), pre-processing, 
+interpolation, ``cooking'', and post-processing. This order of
+precedence is conceptually logical, but is also constrained by the 
+OASIS3 software internal structure.
+
+In the following paragraphs, it is first described how to use OASIS3
+in an interpolator-only mode. Then a description of each
+transformation with its corresponding configuring lines is given.
+
+\section{Using OASIS3 in the interpolator-only mode}
+\label{subsec_interpolator}
+
+OASIS3 can be used in an interpolator-only mode, in which case it 
+ transforms fields without running any model.  It is
+ recommended to use first OASIS3 in this mode
+ to test different transformations and interpolations without
+ having to run the whole coupled system. In the interpolator-only mode,
+ all transformations, except the time transformations, are available.
+
+To run OASIS3 in an interpolator-only mode, the user has to prepare
+the {\it namcouple} as indicated in sections
+\ref{subsec_namcouplefirst} and \ref{subsec_namcouplesecond}. In
+particular, {\tt NONE} has to be chosen below the keyword {\tt
+\$CHANNEL}; ``0'' (without any model name and Fortran unit number)
+must be given below the keyword {\tt \$NBMODEL}; {\tt \$RUNTIME} has
+to be the number of time occurrences of the field to interpolate from
+the NetCDF input file\footnote{For binary input file, only one time
+occurence may be interpolated}; finally, the ``coupling'' period of
+the field (4th entry on the field first line) must be always ``1''.
+Note that if {\tt \$RUNTIME} is smaller than the total number of time
+ocurrences in the input file, the first {\tt \$RUNTIME} occurrences
+will be interpolated.
+
+The name of the input file which contains the fields to interpolate is
+given by the 6th entry on the field first line (see
+\ref{subsec_namcouplesecond}). A positive LAG has to be defined for the
+field so that the input file is opened at the beginning of the
+run. After their transformation, OASIS3 writes them to their output
+file which name is the 7th entry on the first line. Note that all
+fields have to be present in the same restart file.
+
+The time variable in the input file, if any, is recognized by the its
+attribute "units".  The acceptable units for time are listed in the
+udunits.dat file \cite{udunits}.  This follows the CF convention.
+A practical example on how to use OASIS3 in a interpolator-only mode
+is given in {\tt prism/util/running/toymodel/testinterp} (from CERFACS
+CVS only). 
+
+The configuring parameters that have to be defined in the {\it
+namcouple} for each transformation in the interpolator-only mode or in
+the coupling mode are described here after.
+ 
+%{Running OASIS3 in the interpolator-only mode}
+
+\section{The time transformations}
+\label{subsec_timetrans}
+
+{\tt LOCTRANS} can be chosen as first transformation if
+CLIM/MPI1-MPI2 communication and the PSMILe interface are used. {\tt
+LOCTRANS} requires one configuring line on which a time
+transformation, automatically performed below the call to PSMILe {\tt
+prism\_put\_proto}, should be indicated:
+
+\begin{itemize}
+\item {\tt INSTANT}: no time transformation, the instantaneous field is
+transferred; 
+\item {\tt ACCUMUL}: the field accumulated over the previous coupling
+period is transferred; 
+\item {\tt AVERAGE}: the field averaged over the previous
+coupling period is transferred;  
+\item {\tt T\_MIN}: the minimum value of the field
+for each source grid point over the previous coupling period is
+transferred; 
+\item {\tt T\_MAX}: the maximum value of the field for each source grid
+point over the previous coupling period is transferred;
+\item ONCE: only one {\tt prism\_put\_proto} or {\tt
+prism\_get\_proto} will be performed; this is equivalent to giving the
+length of the run as coupling or I/O period.
+\end{itemize}
+
+\section{The pre-processing transformations}
+\label{subsec_preproc}
+
+The following transformations are available in the pre-processing part of
+OASIS3, controlled by {\tt preproc.f}.
+ 
+\begin{itemize}
+
+\item {\bf REDGLO} (not recommended anymore as
+ interpolations now exist directly for Reduced grids): 
+
+ {\tt REDGLO} (routine {\tt redglo.f}) performs the interpolation from a
+ Reduced grid to a Gaussian one. The interpolation is linear and
+ performed latitude circle per
+ latitude circle. When present, REDGLO must be the first pre-processing
+ transformation performed.
+ The configuring line is as follows:
+ \begin{verbatim}
+ # REDGLO operation
+     $NNBRLAT  $CDMSK \end{verbatim}where {\tt \$NNBRLAT} is NOxxx 
+ where xxx is half the number of latitude circles of the Gaussian
+ grid. For example, for a T42 with 64 latitude circles, {\tt
+ \$NNBRLAT} is ``NO32''. In the current version, it can be either
+ NO16, NO24, NO32, NO48, NO80, NO160.{\tt \$CDMSK} is a flag
+ indicating if non-masked values have to be extended to masked areas
+ before interpolation ({\tt \$CDMSK = SEALAND}) using the Reduced grid
+ mask (see section \ref{subsec_griddata}) or if the opposite has to be
+ performed ({\tt \$CDMSK = LANDSEA}).  If {\tt \$CDMSK = NOEXTRAP},
+ then no extrapolation is performed.
+
+\item {\bf INVERT}: 
+
+ {\tt INVERT} (routine {\tt invert.f}) reorders a field so that it
+ goes from south to north and from west to east (the first point will
+ be the southern and western most one; then it goes parallel by parallel
+ going from south to north). {\tt INVERT} should be used only for
+ fields associated to A, B, G, L, Z, or Y grids (see annexe
+ \ref{subsec_gridtypes}) but produced by the source model from North to
+ South and/or from East to West. {\tt INVERT} does not work for
+ Reduced ('D') or unstructured ('U') grids (see annexe
+ \ref{subsec_gridtypes}).
+
+ The generic input line is as follows:
+ \begin{verbatim}
+ # INVERT operation
+     $CORLAT  $CORLON \end{verbatim} where
+ {\tt \$CORLAT = NORSUD} or {\tt SUDNOR} and {\tt \$CORLON = ESTWST}
+ or {\tt WSTEST} describes the orientation of the source field in
+ longitude and latitude, respectively. 
+
+\item {\bf MASK}: 
+ 
+ {\tt MASK} (routine {\tt masq.f}) is used before the analysis {\tt
+ EXTRAP}.  A given {\tt REAL} value {\tt VALMASK} is assigned to all masked
+ points following the source grid mask (see section
+ \ref{subsec_griddata}), so they can be detected by {\tt EXTRAP}.
+
+ The generic input line is as follows:
+ \begin{verbatim}
+ # MASK operation
+     $VALMASK \end{verbatim}Problems may arise if the value chosen
+ approaches the maximum value that your computing platform can
+ represent; choose a value well outside the range of
+ your field values but not too large.
+
+\item {\bf EXTRAP}: 
+
+ {\tt EXTRAP} (routine {\tt extrap.f}) performs the extrapolation of a
+ field over its masked points.  The analysis {\tt MASK} must be used
+ just before, so that {\tt EXTRAP} can identify masked points. Note
+ that {\tt EXTRAP} does not work for Reduced ('D') or unstructured
+ ('U') grids (see section \ref{subsec_gridtypes}).
+
+ Two methods of extrapolation are available. With {\tt NINENN}, a
+ N-nearest-neighbour method is used. The procedure is iterative and the
+ set of remaining masked points evolves at each iteration.  The
+ configuring line is:
+ \begin{verbatim}
+ # EXTRAP operation for $CMETH = NINENN
+     $CMETH  $NV  $NIO  $NID\end{verbatim} where
+ {\tt \$CMETH = NINENN}; {\tt \$NV} is the minimum number
+ of neighbours required to perform the extrapolation (with a maximum
+ of 4)\footnote{For some grids, the extrapolation may not converge if
+ {\tt \$NV} is too large.}; {\tt \$NIO} is the flag that
+ indicates if the weight-address-and-iteration-number dataset will be
+ calculated and written by OASIS3 ({\tt \$NIO}= 1), or only read ({\tt
+ \$NIO}= 0) in file {\em nweights} (see section
+ \ref{subsec_transformationdata}); {\tt \$NID} is the identificator for
+ the weight-address-iteration-number dataset in all the different
+ {\tt EXTRAP/NINENN} datasets in the present coupling.\footnote{An
+ {\tt EXTRAP/NINENN} analysis is automatically performed within {\tt GLORED}
+ analysis but the corresponding datasets have to be distinct; this is 
+ automatically checked by OASIS3 at the beginning of the run.}
+
+ With {\tt \$CMETH = WEIGHT}, an N-weighted-neighbour extrapolation
+ is performed. In that case, the user has to build the grid-mapping
+ file, giving for each target grid point the weights and addresses
+ of the source grid points used in the extrapolation; the structure of this
+ file has to follow the OASIS3 generic structure for transformation
+ auxiliary data files (see section \ref{subsec_transformationdata}).
+
+ The configuring line is:
+ \begin{verbatim}
+ # EXTRAP operation for $CMETH = WEIGHT
+     $CMETH  $NV  $CFILE  $NUMLU  $NID\end{verbatim} where
+ {\tt \$CMETH = WEIGHT}; {\tt \$NV} is the maximum number of
+ neighbours required by the extrapolation operation; {\tt \$CFILE} and
+ {\tt \$NUMLU} are the grid-mapping file name and associated logical
+ unit; {\tt \$NID} is the identificator for the relevant grid-mapping
+ dataset in all different {\tt EXTRAP/WEIGHT} transformations in the present
+ coupling.
+
+
+ 
+\item {\bf CHECKIN}:
+
+ {\tt CHECKIN} (routine {\tt chkfld.f}) calculates the mean and extremum
+ values of the source field and prints them to the coupler log file
+ {\em cplout}.
+
+ The generic input line is as follows:
+ \begin{verbatim}
+ # CHECKIN operation
+     $NINT   \end{verbatim} where
+ {\tt \$NINT} = 1 or 0, depending on whether or not the source
+ field integral is also calculated and printed.
+
+\item {\bf CORRECT}:
+ 
+ {\tt CORRECT} (routine {\tt correct.f}) reads external fields from binary
+ files and uses them to modify the coupling field. This transformation
+ can be used, for example, to perform flux correction on the field.
+
+ This transformation requires at least one configuration line with two
+ parameters:
+ \begin{verbatim}
+ # CORRECT operation 
+     $XMULT  $NBFIELDS \end{verbatim} where
+ {\tt \$XMULT} is the multiplicative coefficient of the current
+ field, and {\tt \$NBFIELDS} the number of additional fields to be
+ combined with the current field.  For each additional field, an
+ additional configuring line is required:
+ \begin{verbatim}
+ # nbfields lines
+     $CLOC  $AMULT  $CFILE  $NUMLU \end{verbatim} where
+ {\tt \$CLOC} and {\tt \$AMULT}, {\tt \$CFILE} and {\tt \$NUMLU}
+ are respectively the symbolic name, the multiplicative coefficient,
+ the file name and the associated logical unit on which the additional
+ field is going to be read. The structure of the file has to follow
+ the structure of OASIS3 binary coupling restart files (see section
+ \ref{subsec_restartdata}).
+
+\end{itemize}
+
+%subsection{The pre-processing transformations}
+
+\section{The interpolation}
+\label{subsec_interp}
+
+The following interpolations, controlled by {\tt interp.f}, are
+available in OASIS3.
+
+\begin{itemize}
+
+\item {\bf BLASOLD}: 
+
+{\tt BLASOLD} (routine {\tt blasold.f}) performs a linear combination of the
+current coupling field with other coupling fields or with a constant
+before the interpolation {\it per se}.
+
+This transformation requires at least one configuring line with two
+parameters:
+\begin{verbatim}
+ # BLASOLD operation 
+     $XMULT     $NBFIELDS\end{verbatim}where
+{\tt \$XMULT} is the multiplicative coefficient of the current
+field, and {\tt \$NBFIELDS} the number of additional fields to be
+combined with the current field.  For each additional field, an
+additional input line is required:
+\begin{verbatim}
+# nbfields lines
+     $CNAME  $AMULT
+\end{verbatim}
+where {\tt \$CNAME} and {\tt \$AMULT} are the symbolic name and the 
+multiplicative coefficient for the additional field. To add a
+constant value to the original field, put {\tt \$XMULT} = 1, {\tt
+\$NBFIELDS} = 1, {\tt \$CNAME = CONSTANT}, {\tt \$AMULT} = value to
+add.
+
+\item {\bf SCRIPR}:
+ 
+  {\tt SCRIPR} is new in OASIS3 and gathers the interpolation
+  techniques offered by Los Alamos National Laboratory SCRIP 1.4
+  library\footnote{See the copyright statement in annexe
+  \ref{sec_SCRIP}.}\cite{SCRIPR}. {\tt SCRIPR} routines are in {\tt
+  prism/src/lib/scrip}. See also the SCRIP 1.4
+  documentation in  {\tt prism/src/mod/oasis3/doc/SCRIPusers.pdf}.
+  Linking with NetCDF library is mandatory when using
+  {\tt SCRIPR} interpolations.
+
+  The following types of interpolations are available:
+
+  \begin{itemize}
+
+  \item {\tt DISTWGT} performs N nearest-neighbour interpolation (N
+  neighbours). All grid types are supported. If the N nearest
+  neighbours of a target grid point are masked, no value is calculated
+  for that point; transformations {\tt MASK} and {\tt EXTRAP} should
+  be used to avoid problems for those points. No values are calculated
+  for masked target grid points.
+
+  The configuring line is:
+
+  \begin{verbatim}
+ # SCRIPR/DISWGT 
+  $CMETH $CGRS $CFTYP $REST $NBIN $NV $ASSCMP $PROJCART\end{verbatim} where:
+  \begin{itemize} 
+  \item {\tt \$CMETH = DISTWGT}. 
+  \item {\tt \$CGRS} is the source grid
+  type ({\tt LR}, {\tt D} or {\tt U})- see annexe
+  \ref{subsec_gridtypes}. 
+
+  \item {\tt \$CFTYP} is the field type: {\tt SCALAR} if the field is
+  a scalar one, or {\tt VECTOR\_I} or {\tt VECTOR\_J} whether the
+  field represents respectively the first or the second component of a
+  vector field (see paragraph {\bf Support of vector fields}
+  below). Note that {\tt VECTOR}, which is fact leads to a scalar treatment
+  of the field (as in the previous versions), is still supported.
+
+  \item {\tt \$REST} is the search restriction type: {\tt LATLON}
+  or {\tt LATITUDE} (see SCRIP 1.4 documentation). Note that for {\tt
+  D} or {\tt U} grid, the restriction may influence sligthly the
+  result near the borders of the restriction bins.
+  \item {\tt \$NBIN} the number of restriction bins (see SCRIP 1.4
+  documentation).
+  \item {\tt \$NV} is the number of neighbours used.
+  \item {\tt \$ASSCMP}: optional, for {\tt VECTOR\_I} or {\tt VECTOR\_J} vector fields only; the source symbolic name of the associated vector component.
+  \item {\tt \$PROJCART}: optional, for vector fields only; should be {\tt PROJCART} if the user wants the vector components to be projected in a Cartesian coordinate system before interpolation (see paragraph {\bf Support of vector fields} below). 
+  \end{itemize}
+
+  \item {\tt GAUSWGT} performs N nearest-neighbour interpolation
+  weighted by a gaussian function. All grid types are
+  supported. Behaviour for source and target masked points is the same
+  than for {\tt DISTWGT}. The configuring line is:
+  \begin{verbatim}
+ # SCRIPR/GAUSWGT
+$CMETH  $CGRS  $CFTYP  $REST  $NBIN  $NV $VAR $ASSCMP $PROJCART\end{verbatim} where all entries are as for  {\tt DISTWGT}, except that:
+  \begin{itemize} 
+   \item {\tt \$CMETH = GAUSWGT}
+   \item {\tt \$VAR}, which must be given as a
+    REAL value (e.g 2.0 and not 2), defines the weight given to a
+    neighbour source grid point as inversely
+    proportional to $exp(-1/2 \cdot d^2/\sigma^2)$ where $d$ is the
+    distance between the source and target grid points, and $\sigma^2 =
+    \$VAR \cdot \overline{d}^2$ where $\overline{d}^2$ is the average
+    distance between two source grid points (calculated automatically
+    by OASIS3).
+  \end{itemize}
+
+  \item {\tt BILINEAR} performs bilinear interpolation.
+
+  \item {\tt BICUBIC} performs a bicubic interpolation.
+ 
+  For {\tt BILINEAR} and {\tt BICUBIC}, Logically-Rectangular (LR) and
+  Reduced (D) source grid types are supported. If the some of the
+  source grid points NORMlly used in the bilinear or bicubic
+  interpolation are masked, another algorithm is applied; at least,
+  the nearest non-masked source neighbour is used.  No values are
+  calculated for masked target grid points.
+
+  The configuring line is:
+
+  \begin{verbatim}
+ # SCRIPR/BILINEAR or SCRIPR/BICUBIC
+     $CMETH  $CGRS  $CFTYP  $REST  $NBIN $ASSCMP $PROJCART\end{verbatim}where:
+  \begin{itemize}
+  \item {\tt \$CMETH = BILINEAR} or {\tt BICUBIC}
+  \item {\tt \$CGRS} is the source grid type (LR or D)
+  \item {\tt \$CFTYP}, {\tt \$NBIN}, {\tt \$ASSCMP} {\tt \$PROJCART} are
+  as for {\tt DISTWGT}. 
+  \item {\tt \$REST} is as for {\tt DISTWGT}, except that only
+  {\tt LATITUDE} is possible for a Reduced (D) source grid.
+  \end{itemize}
+ 
+  \item {\tt CONSERV} performs 1st or 2nd order conservative remapping,
+  which means that the weight of a source cell is proportional to area
+  intersected by target cell. Values are possibly calculated for all
+  target grid points whether they are masked or not. The source grid
+  mask is taken into account in the NORMlisation (see below).
+ 
+  The configuring line is:
+  \begin{verbatim}
+ # SCRIPR/CONSERV
+$CMETH  $CGRS  $CFTYP  $REST  $NBIN  $NORM  $ORDER $ASSCMP $PROJCART\end{verbatim}where: 
+  \begin{itemize}
+  \item {\tt \$CMETH = CONSERV} 
+  \item {\tt \$CGRS} is the source grid type: LR, D and U are
+  supported for 1st-order remapping if the grid corners are given by
+  the user in the grid data file which is, in this case, necessarily a
+  netCDF file (grids.nc, see section \ref{subsec_griddata}); only LR
+  is supported if the grid corners are not available in the grid data
+  file and therefore have to be calculated automatically by
+  OASIS3. For second-order remapping, only LR is supported because the
+  gradient of the coupling field used in the transformation has to be
+  calculated automatically by OASIS3.
+  \item {\tt \$CFTYP, \$REST}, {\tt \$NBIN}, {\tt \$ASSCMP},and {\tt \$PROJCART} are as for {\tt
+  DISTWGT}. Note that for {\tt CONSERV} the restriction does not
+  influence the result.
+  \item {\tt \$NORM} is the NORMlization option:
+  \begin{itemize}
+   \item {\tt FRACAREA}: The sum of the source cell intersected areas
+    is used to NORMlise each target cell field value: the flux is not
+    locally conserved, but the flux value itself is reasonable.
+   \item  {\tt DESTAREA}: The total target cell area is used to NORMlise each
+    target cell field value even if it only partly intersects the source
+    grid cells: local flux conservation is ensured, but
+    unreasonable flux values may result.
+   \item  {\tt FRACNNEI}: as {\tt FRACAREA}, except that the source nearest 
+    neighbour is used for target cells that do not intersect any
+    unmasked source cells.
+  \end{itemize} 
+\item {\tt \$ORDER}: {\tt FIRST} or {\tt SECOND}\footnote{{\tt
+  CONSERV/SECOND} has not been tested in detail.} for first or second
+  order remapping respectively (see SCRIP 1.4 documentation).
+\end{itemize}
+\end{itemize}
+
+{\bf Support of vector fields}
+
+{\tt SCRIPR} supports 2D vector interpolation. The two vector
+components have to be identified by replacing {\tt \$CFTYP} by {\tt
+VECTOR\_I} or {\tt VECTOR\_J} and have to be associated by replacing
+{\tt \$ASSCMP}, for each component field, by the source symbolic name
+of the associated vector component in (see above). A proper example of
+vector interpolation is given in the interpolator-only mode example
+(see details in {\tt
+prism/util/running/testinterp/README\_testinterp}). The details of the
+vector treatment, performed by the routines {\tt scriprmp\_vector.F90}
+and {\tt rotations.F90} in {\tt prism/src/lib/scrip/src} are the
+following:
+
+\begin{itemize}
+\item If the angles of the source grid local coordinate system are defined in the {\it grids.nc} data file (see section \ref{subsec_griddata}), an automatic rotation from the local to the geographic spherical coordinate system is performed.
+\item If the two source vector components are not defined on the same source grid, one component is automatically interpolated on the grid of the other component.
+\item If the user put the {\tt PROJCART} keyword at the end of the
+{\tt SCRIPR} configuring line (see above), projection of the two
+vector components in a Cartesian coordinate system, interpolation of
+the resulting 3 Cartesian components, and projection back in the
+spherical coordinate system are performed. In debug mode (compilation
+with {\tt DEBUG} pre-compiling key), the resulting vertical component
+in the spherical coordinate system after interpolation is written to a
+file {\tt projection.nc}; as the source vector is horizontal, this component should be very close to 0.  
+\item If the user did not put the {\tt PROJCART} keyword at the end of the {\tt SCRIPR} configuring line, the two spherical coordinate system components are interpolated.
+\item If the angles of the target grid local coordinate system are defined in the {\it grids.nc} data file (see section \ref{subsec_griddata}), an automatic rotation from the geographic spherical to the local coordinate system is performed.
+\item The first and second components of the interpolated vector field are then present in the target fields associated respectively to the first and second source vector component. The target grids for the two vector components can be different. 
+\end{itemize}
+
+\vspace{1cm}
+\item {\bf INTERP}: 
+
+%-Note sur le traitement des points masqus dans OASIS:
+%Note: Le champ interpol fldnew est initialis  zro. La valeur du 
+%masque de la grille source n'est pas change ni par masq.f ni par
+%extrap.f.
+%
+%SURFMESH:
+% -les points source masqus ne sont pas utiliss.
+% -le calcul des poids est fait pour tous les points cible mais les poids et
+%  adresses des points masqus sont remis  0 et 1.
+% -le calcul du champ interpol n'est fait que pour les points cible
+%  non-masqus. 
+%BILINEAR, BICUBIC, NNEIBOR:
+% -tous les points source, mme masqus, sont utiliss (c'est pour a
+%  qu'il faut faire MASK et EXTRAP avant).
+% -le calcul des poids est fait pour tous les points cibles 
+%  masqus ou pas.
+% -le calcul du champ interpol est fait pour tous les points cibles 
+%  masqus ou pas.
+%GAUSSIAN: 
+% -les points source masqus ne sont pas utiliss.
+% -le calcul des poids n'est fait que pour les points cible
+% non-masqus.
+% -le calcul du champ interpol n'est fait que pour les points cible
+% non-masqus. 
+%
+  {\tt INTERP} gathers different techniques of interpolation controlled by 
+  routine {\tt fiasco.f}. The following interpolations are available:
+
+  \begin{itemize}
+
+   \item {\tt BILINEAR} performs a bilinear interpolation using 4
+    neighbours. 
+
+   \item {\tt BICUBIC} performs a bicubic interpolation.
+
+   \item {\tt NNEIBOR} performs a nearest-neighbour interpolation.
+
+  These three interpolations are performed by routines in {\tt
+  /prism/src/lib/fscint} and support only A, B,
+  G, L, Y, or Z grids (see annexe
+  \ref{subsec_gridtypes}). All sources grid points, masked or not, are
+  used in the calculation. To avoid the `contamination' by masked
+  source grid points, transformations {\tt MASK} and {\tt EXTRAP}
+  should be used. Values are calculated for all target grid points,
+  masked or not.
+
+  The configuring line is as follows:
+    \begin{verbatim}
+ # BILINEAR or BICUBIC or NNEIBOR interpolation 
+    $CMETH $CGRS $CFTYP \end{verbatim} where 
+     \begin{itemize}
+     \item {\tt \$CMETH = BILINEAR}, {\tt BICUBIC} or {\tt NNEIBOR} 
+     \item {\tt \$CGRS} is the source grid type (A, B, G, L, Y, or
+     Z, see annexe \ref{subsec_gridtypes})
+     \item {\tt \$CFTYP} the field type ({\tt SCALAR} or {\tt
+  VECTOR}). {\tt VECTOR} has an effect for target grid points located
+  near the pole: the sign of a source value located on
+  the other side of the pole will be reversed. 
+     \end{itemize}
+
+   \item {\tt SURFMESH} (routines in {\tt /prism/src/lib/anaism}) is a
+    first-order conservative remapping from a fine to a coarse grid
+    (the source grid must be finer over the whole domain) and supports
+    only Lat-Lon grids. For a target grid cell, all the underlying not
+    masked source grid cells are found and the target grid field value
+    is the sum of the source grid field values weighted by the
+    overlapped surfaces. No value is assigned to masked cells. Note
+    that it is not recommended to use this interpolation anymore, as
+    the more general {\tt SCRIPR/CONSERV} remapping is now available.
+    The configuring line is as follows:
+
+    \begin{verbatim}
+ # SURFMESH remapping
+     $CMETH $CGRS $CFTYP $NID $NV $NIO\end{verbatim} where 
+     \begin{itemize}
+     \item {\tt \$CMETH = SURFMESH}
+     \item {\tt \$CGRS} and {\tt \$CFTYP} are as for {\tt BILINEAR}
+     \item {\tt \$NID} is the identificator for the weight-address
+    dataset in all the different {\tt INTERP/SURFMESH} datasets in the
+    present coupling.  This dataset will be calculated by OASIS3 if
+    {\tt \$NIO}= 1, or only read if {\tt \$NIO}= 0.
+    \item {\tt \$NV} is the maximum number of source grid meshes
+    used in the remapping.
+    \end{itemize} 
+
+    \item {\tt GAUSSIAN} (routines in {\tt /prism/src/lib/anaisg}) is a 
+     gaussian weighted nearest-neighbour interpolation technique.
+    The user can choose the variance of the function and the number of
+    neighbours considered. The masked source grid points are not used
+    and no value are calculated for masked target grid points. 
+
+    The configuring line is:
+    \begin{verbatim}
+    # GAUSSIAN interpolation
+    $CMETH $CGRS $CFTYP $NID $NV $VAR  $NIO\end{verbatim}where 
+    \begin{itemize}
+    \item {\tt \$CMETH = GAUSSIAN}
+    \item {\tt \$CGRS} is the source grid type ({\tt LR, D} or {\tt U}) and {\tt \$CFTYP} is as for the {\tt DISTWGT}
+    % (in the {\tt U} case the surface calculation is wrong XXXXX).
+    \item {\tt \$NID} is the identificator for the
+    weight-address dataset in all the different {\tt INTERP/GAUSSIAN}
+    datasets in the present coupling. This weight-address dataset will
+    be calculated by OASIS3 if {\tt \$NIO}= 1, or only read if {\tt
+    \$NIO}= 0. 
+    \item {\tt \$NV} is the number of neighbours used in the
+    interpolation. 
+    \item {\tt \$VAR} is as for {\tt SCRIPR/GAUSWGT} (see above).
+    \end{itemize}
+\end{itemize}
+
+\item {\bf MOZAIC}: 
+
+{\tt MOZAIC} performs the mapping of a field from a source to a target
+grid. The grid-mapping dataset, i.e. the weights and addresses of the
+source grid points used to calculate the value of each target grid
+point are defined by the user in a file (see section
+\ref{subsec_transformationdata}).  The configuring line is:
+\begin{verbatim}
+# MOZAIC operation
+     $CFILE  $NUMLU  $NID  $NV
+\end{verbatim}where 
+\begin{itemize}
+\item{\tt \$CFILE} and {\tt \$NUMLU} are the grid-mapping file name
+and associated logical unit on which the grid-mapping dataset is going
+to be read),
+\item {\tt \$NID} the identificator for this grid-mapping dataset in
+all {\tt MOZAIC} grid-mapping datasets in the present coupling
+\item {\tt \$NV} is the maximum number of target grid points use
+in the mapping.
+\end{itemize}
+
+\item {\bf NOINTERP}: 
+
+{\tt NOINTERP} is the analysis that has to be chosen when no other
+transformation from the interpolation class is chosen.
+There is no configuring line.
+
+\item {\bf FILLING}: 
+
+{\tt FILLING} (routine {\tt /prism/src/mod/oasis3/src/filling.f})
+performs the blending of a regional data set with a climatological
+global one for a Sea Surface Temperature (SST) or a Sea Ice Extent
+field. This occurs when coupling a non-global ocean model with a
+global atmospheric model. {\tt FILLING} can only handle
+fields on Logically Rectangular grid (LR, but also A, B,
+G, L, Y, and Z grids, see section \ref{subsec_gridtypes}.
+
+The global data set has to be a set of SST
+given in Celsius degrees (for the filling of a Sea Ice Extent field,
+the presence or absence of ice is deduced from the value of the
+SST). The frequency of the global set can be interannual monthly,
+climatological monthly or yearly.
+
+The blending can be smooth or abrupt. If the blending is abrupt, only
+model values are used within the model domain, and only the global
+data set values are used outside. If the blending is smooth, a linear
+interpolation is performed between the two fields within the model
+domain over narrow bands along the boundaries. The linear
+interpolation can also be performed giving a different weight to the
+regional or and global fields. 
+
+ The smoothing is defined by parameters in {\tt
+/prism/src/mod/oasis3/src/} \-\-\- {\tt mod\_smooth.F90}. The lower smoothing band
+in the global model second dimension is defined by {\em nsltb}
+(outermost point) and {\em nslte} (innermost point); the upper
+smoothing band in the global model second dimension is defined by {\em
+nnltb} (outermost point) and {\em nnlte} (innermost point). The
+parameter {\em qalfa} controls the weights given to the regional and
+to the global fields in the linear interpolation. {\em qalfa} has to
+be $1/(nslte-nsltb)$ or $1/(nnltb-nnlte)$. For the outermost points
+({\em nsltb} or {\em nnltb}) in the smoothing band, the weight given
+to the regional and global fields will respectively be 0 and 1; for
+the innermost points ({\em nslte} or {\em nnlte}) in the smoothing
+band, the weight given to the regional and global fields will
+respectively be 1 and 0; within the smoothing band, the weights will
+be a linear interpolation of the outermost and innermost weights.
+
+The smoothing band in the global model first dimension will be a band
+of {\em nliss} points following the coastline. To calculate this band,
+OASIS3 needs {\em nwlgmx}, the greater first dimension index of the
+lower coastline and {\em nelgmx}, the smaller first dimension index on
+the upper coastline. The parameter {\em qbeta} controls the weights
+given to the regional and to the global fields in the linear
+interpolation. {\em qbeta} has to be $1/(nliss-1)$. The weights given
+to the regional and global fields in the global model first dimension
+smoothing bands will be calculated as for the second dimension.
+
+The user must provide the climatological data file with
+a specific format described in \ref{subsec_transformationdata}. 
+When one uses {\tt FILLING} for SST with smooth blending, thermodynamics 
+consistency requires to modify the heat fluxes over the blending 
+regions. The correction term is proportional to the difference between
+the blended SST and the original SST interpolated on the atmospheric 
+grid and can be written out on a file to be read later, for analysis
+{\tt CORRECT} for example. In that case, the symbolic name of the flux
+correction term read through the input file {\em namcouple} must 
+correspond in {\tt FILLING} and {\tt CORRECT} analyses.
+
+In case the regional ocean model includes a coastal part or islands, a
+sea-land mask mismatch may occur and a coastal point correction can be
+performed if the field has been previously interpolated with {\tt
+INTER/SURFMESH}. In fact, the
+mismatch could result in the atmosphere undesirably ``seeing''
+climatological SST's directly adjacent to ocean model SST's.  Where
+this situation arises, the coastal correction consists in identifying
+the suitable ocean model grid points that can be used to extrapolate
+the field, excluding climatological grid points.
+
+This analysis requires one configuring line with 3, 4 or 6 arguments.
+
+\begin{enumerate}
+\item If FILLING performs the blending of a regional data set with a
+global one for the Sea Ice Extent, the 3-argument input line is:
+\begin{verbatim}
+# Sea Ice Extent FILLING operation
+     $CFILE  $NUMLU  $CMETH\end{verbatim} where {\tt \$CFILE} is 
+the file name for the global data set, {\tt \$NUMLU} the associated
+logical unit. {\tt \$CMETH}, the {\tt FILLING} technique, is a {\tt
+CHARACTER*8} variable: the first 3 characters are either {\tt SMO},
+smooth filling, or {\tt RAW}, no smoothing ; the next three characters
+must be {\tt SIE} for a Sea Ice Extent filling operation; the last two
+define the time characteristics of the global data file, respectively
+{\tt MO}, {\tt SE} and {\tt AN} for interannual monthly,
+climatological monthly and yearly. Note that in all cases, the global
+data file has to be a Sea Surface Temperature field in Celsius
+degrees.
+
+\item If FILLING performs the blending of a regional data set with a
+global one for the Sea Surface Temperature without any smoothing, the
+4-argument input line is:
+\begin{verbatim}
+#Sea Surface Temperature FILLING operation without smoothing
+     $CFILE  $NUMLU  $CMETH  $NFCOAST\end{verbatim} where 
+{\tt \$CFILE}, {\tt \$NUMLU} are as for the SIE filling. In this
+case however, {\tt \$CMETH(1:3) = RAW}, {\tt \$CMETH(4:6) = SST}, 
+and the last two characters define the time characteristics of the 
+global data file, as for the SIE filling. {\tt \$NFCOAST} is  
+the flag for the calculation of the coastal correction ( 0 no, 1 yes).
+
+\item If FILLING performs the blending of a regional data set with a
+global one for the Sea Surface Temperature with smoothing, the
+6-argument input line is:
+\begin{verbatim}
+#Sea Surface Temperature FILLING operation with smoothing
+     $CFILE  $NUMLU  $CMETH  $NFCOAST  $CNAME  $NUNIT\end{verbatim}
+     where {\tt \$CFILE}, {\tt \$NUMLU} and {\tt \$NFCOAST} are as for the SST
+filling without smoothing. In this case, {\tt \$CMETH(1:3) = SMO},
+{\tt \$CMETH(4:6) = SST}, and the last two characters define the
+time characteristics of the global data file, as for the SIE
+filling. {\tt \$CNAME} is the symbolic name for the correction
+term that is calculated by OASIS3 and {\tt \$NUNIT} the logical
+unit on which it is going to be written. 
+
+\end{enumerate}
+
+\end{itemize}
+
+%subsection{The interpolation}
+
+\section{The ``cooking'' stage}
+\label{subsec_cooking}
+
+The following analyses are available in the ``cooking'' part of
+OASIS3, controlled by {\tt cookart.f}.
+
+\begin{itemize}
+
+\item {\bf CONSERV}: 
+
+{\tt CONSERV} (routine {\tt /prism/src/mod/oasis3/src/conserv.f})
+performs global flux conservation. The flux is integrated on both
+source and target grids, without considering values of masked points,
+and the residual (target - source) is calculated. Then all flux values
+on the target grid are uniformly modified, according to their
+corresponding surface.  This analysis requires one input line with one
+argument:
+\begin{verbatim}
+# CONSERV operation
+     $CMETH\end{verbatim}where {\tt \$CMETH} is the conservation method required. In this
+version, only global flux conservation can be performed. Therefore
+{\tt \$CMETH} must be {\tt GLOBAL}.
+   
+\item {\bf SUBGRID}: 
+
+{\tt SUBGRID} can be used to interpolate a field from a coarse grid to a
+finer target grid (the target grid must be finer over the whole
+domain). Two types of subgrid interpolation can be performed,
+depending on the type of the field.
+
+For solar type of flux field ({\tt \$SUBTYPE = SOLAR}), the operation
+performed is:
+$$\Phi_{i} = \frac{1-\alpha_i}{1-\alpha} F$$ where $\Phi_{i}$ ($F$) is
+the flux on the fine (coarse) grid, $\alpha_i$ ($\alpha$) an auxiliary
+field on the fine (coarse) grid (e.g. the albedo).  The whole
+operation is interpolated from the coarse grid with a grid-mapping type
+of interpolation; the dataset of weights and addresses has to be given
+by the user.
+
+For non-solar type of field ({\tt \$SUBTYPE = NONSOLAR}), a
+first-order Taylor expansion of the field on the fine grid relatively
+to a state variable is performed (for instance, an expansion of the
+total heat flux relatively to the SST):
+$$\Phi_{i} = F + \frac{\partial F}{\partial T} ( T_i - T ) $$ where
+$\Phi_{i}$ ($F$) is the heat flux on the fine (coarse) grid, $T_i$
+($T$) an auxiliary field on the fine (coarse) grid (e.g. the SST) and
+$\frac{\partial F}{\partial T}$ the derivative of the flux versus the
+auxiliary field on the coarse grid. This operation is interpolated
+from the coarse grid with a grid-mapping type of interpolation; the
+dataset of weights and addresses has to be given by the user.
+
+This analysis requires one input line with 7 or 8
+arguments depending on the type of subgrid interpolation.
+
+\begin{enumerate}
+\item If the the {\tt SUBGRID} operation is performed on a solar flux,
+the 7-argument input line is:
+\begin{verbatim}
+# SUBGRID operation with $SUBTYPE=SOLAR 
+  $CFILE  $NUMLU  $NID  $NV  $SUBTYPE  $CCOARSE $CFINE\end{verbatim}where
+{\tt \$CFILE} and {\tt \$NUMLU} are the subgrid-mapping file name and
+associated logical unit (see section \ref{subsec_transformationdata} for the
+structure of this file); {\tt \$NID} the identificator for this
+subgrid-mapping dataset within the file build by OASIS based on all
+the different {\tt SUBGRID} analyses in the present coupling; {\tt
+\$NV} is the maximum number of target grid points use in the
+subgrid-mapping; {\tt \$SUBTYPE = SOLAR} is the type of subgrid
+  interpolation; {\tt \$CCOARSE} is the
+auxiliary field name on the coarse grid (corresponding to $\alpha$)
+and {\tt \$CFINE} is the auxiliary field name on fine grid
+(corresponding to $\alpha_i$).
+These two fields needs to be exchanged between their original model
+and OASIS3 main process, at least as {\tt AUXILARY} fields.
+This analysis is performed from the coarse grid with a grid-mapping type
+of interpolation based on the {\tt \$CFILE} file.
+
+\item If the the SUBGRID operation is performed on a nonsolar flux,
+the 8-argument input line is:
+\begin{verbatim}
+# SUBGRID operation with $SUBTYPE=NONSOLAR
+  $CFILE $NUMLU $NID $NV $SUBTYPE $CCOARSE $CFINE $CDQDT
+\end{verbatim} where {\tt \$CFILE},  {\tt \$NUMLU},  {\tt \$NID},  
+{\tt \$NV} are as for a solar subgrid interpolation; {\tt
+\$SUBTYPE = NONSOLAR}; {\tt \$CCOARSE} is the auxiliary
+field name on the coarse grid (corresponding to $T$) and {\tt \$CFINE}
+is the auxiliary field name on fine grid (corresponding to $T_i$); the
+additional argument {\tt \$CDQDT} is the coupling ratio on the coarse
+grid (corresponding to $\frac{\partial F}{\partial T}$) These three
+fields need to be exchanged between their original model and OASIS3
+main process as {\tt AUXILARY} fields. This operation is performed from the
+coarse grid with a grid-mapping type of interpolation based on the {\tt
+\$CFILE} file.
+
+\end{enumerate}
+
+\vspace{1cm}
+
+\item {\bf BLASNEW}:
+ 
+{\tt BLASNEW} (routine {\tt /prism/src/mod/oasis3/src/blasnew.f}) performs a linear combination of the
+current coupling field with any other fields after the
+interpolation. These can be other coupling fields or constant fields.
+
+This analysis requires the same input line as {\tt BLASOLD}.
+
+\item {\bf MASKP}:
+
+A new analysis {\tt MASKP} can be used to mask the fields after
+interpolation. {\tt MASKP} has the same generic input line as {\tt MASK}.
+
+\end{itemize}
+
+%subsection{The ``cooking'' stage}
+
+\section{The post-processing}
+\label{subsec_postpro}
+
+The following analyses are available in the post-processing part of
+OASIS3, controlled by {\tt /prism/src/mod/oasis3/src/postpro.f}.
+
+\begin{itemize}
+
+\item {\bf REVERSE}: 
+
+{\tt REVERSE} (routine {\tt /prism/src/mod/oasis3/src/reverse.f})
+reorders a field. 
+
+This analysis requires the same input line as {\tt INVERT}, with {\tt
+\$CORLON} and {\tt \$CORLAT} being now the resulting orientation. 
+{\tt REVERSE} does not work for U and D grids
+(see annexe \ref{subsec_gridtypes}).
+
+\item {\bf CHECKOUT}: 
+
+{\tt CHECKOUT} (routine {\tt /prism/src/mod/oasis3/src/chkfld.f}) calculates
+the mean and extremum values of an output field and prints them to the
+coupler output {\em cplout}.
+
+The generic input line is as for {\tt CHECKIN}.
+
+\item {\bf GLORED} (not recommended as coupling fields can be directly
+ interpolated to a target Reduced grid, if needed):
+
+
+{\tt GLORED} performs a linear interpolation of field from a full
+Gaussian grid to a Reduced grid. When present, {\tt GLORED} must be the last
+analysis performed.
+
+Before doing the interpolation, non-masked values are automatically
+extrapolated to masked points with {\tt EXTRAP/NINENN} method (see
+above); to do so, the masked grid points are first replaced with a
+predefined value.  The required global grid mask must be
+present in data file {\tt masks} or {\tt masks.nc} (see section
+\ref{subsec_griddata}).
+
+The generic input line is as follows:
+\begin{verbatim}
+# GLORED operation
+     $NNBRLAT  $NV   $NIO   $NID\end{verbatim} where {\tt \$NNBRLAT} 
+is as for {\tt REDGLO} (see {\tt REDGLO} description above). 
+The next 3 parameters refer to the {\tt EXTRAP/NINENN} extrapolation
+(see {\tt EXTRAP/NINENN} description above).  The value assigned to
+all land points before interpolation is given by {\tt amskred} in {\tt
+/prism/src/mod/oasis3/src/blkdata.f}; as for the {\tt \$VALMASK} in
+{\tt MASK} analysis, it has to be chosen well outside the range of
+your field values but not too large to avoid any representation problem. 
+
+\end{itemize}
+
+%subsection{The post-processing}
+
+%subsection{Input line(s) for each transformation}
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG5_Auxiliary_files.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG5_Auxiliary_files.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG5_Auxiliary_files.tex	(revision 1677)
@@ -0,0 +1,351 @@
+\newpage
+\chapter{OASIS3 auxiliary data files}
+\label{sec_auxiliary}
+
+OASIS3 needs auxiliary data files describing coupling and I/O field
+names and units, defining the grids of the models being coupled,
+containing the field coupling restart values or input data values, as
+well as a number of other auxiliary data files used in specific
+transformations. For coupled models distributed in the PRISM Standard 
+Running Environment (SCE), all those files are either automatically
+provided or generated.
+
+\section{Field names and units}
+\label{subsec_cfnametable}
+
+The text file \texttt{cf\_name\_table.txt}, that can be found in
+directory \texttt{prism/util/running\break/adjunct\_files/oasis3}
+directory, contains a list of CF standard names and associated units
+identified with an index. The appropriate index has to be given by the
+user for each coupling or I/O field as the third entry on the field
+first line (see \ref{subsec_namcouplesecond}). This information will
+be used by OASIS3 for its log messages to {\it cplout} file and by the
+PSMILe to produce CF compliant NetCDF files.
+
+\section{Grid data files}
+\label{subsec_griddata}
+
+The grids of the models being coupled can be given by the user or
+directly by the model through PSMILe specific calls (see section
+\ref{subsubsec_griddef}) in grid data files. These files can be all
+binary or all NetCDF. In \break {\tt
+/prism/data/toyclim/input\_toyclim\_standard\_standard\_prism\_2-2.tar.gz},
+Net\-CDF examples can be found.
+
+The
+arrays containing the grid information are dimensioned {\tt (nx, ny)},
+where {\tt nx} and {\tt ny} are the grid first and second dimension,
+except for Unstructured (U) and Reduced (D) grid, for which the
+arrays are dimensioned {\tt (nbr\_pts,1)}, where {\tt nbr\_pts} is the
+total number of grid points. 
+
+\begin{enumerate}
+
+\item {\em grids} or {\em grids.nc}: contains the component model grid
+  longitudes, latitudes, and local angles (if any)  in single or double precision {\tt
+  REAL} arrays (depending on OASIS3 compilation options). The array names
+  must be composed of a prefix (4 characters), given by the user in
+  the {\it namcouple} on the second line of each field (see section
+  \ref{subsec_namcouplesecond}), and of a suffix (4 characters); this
+  suffix is ``.lon'' or ``.lat'' for respectively the grid point
+  longitudes or latitudes (see {\tt /prism/src/mod/oasis3/src\break/mod\_label.F90}.)
+
+ If the {\tt SCRIPR/CONSERV} interpolation is used for a grid, the
+ grid data file may contain longitudes and latitudes for model mesh
+ corners as arrays dimensioned {\tt (nx, ny, 4)} or {\tt
+ (nbr\_pts,1, 4)} where {\tt 4} is the number of corners; in this
+ case, it must necessarily be a NetCDF file ({\em
+ grids.nc}). For Logically Rectangular LR grids, the grid
+ corners will be automatically calculated approximately if they are
+ not given in {\em grids.nc}. The names of the arrays must be
+ composed of the grid prefix and the suffix ``.clo'' or ``.cla'' for
+ respectively the grid corner longitudes or latitudes.
+ 
+ If vector fields are defined on a grid which has a local coordinate system not oriented in the usual zonal and meridional directions, the local angle of the grid coordinate system must be given in {\it grids.nc} file in an array which name must be composed of the grid prefix and the suffix ``.ang''. The angle is defined as the angle between the first component and the zonal direction (which is also the angle between the second component and the meridional direction). In the grid file in {\tt
+/prism/data/toyclim/input\_toyclim\_standard\_standard\_prism\_2-2.tar.gz}, the angles of the {\tt torc} grid are given in array {\tt torc.ang}. If one of the {\tt SCRIPR} interpolations is requested for a vector field, OASIS3 automatically performs the rotation from the local coordinate system to the geographic spherical coordinate system for a source grid, or vice-versa for a target grid.
+ 
+ File {\em grids} or {\em grids.nc} must be present with at least the grid
+ point longitudes and latitudes for all component model. 
+
+\item {\em masks} or {\em masks.nc}: contains the masks for all
+component model grids in {\tt INTEGER} arrays (0 -not masked- or 1
+-masked- for each grid point). The array names must be composed of the
+grid prefix and the suffix ``.msk''. This file, {\em masks} or {\em
+  masks.nc}, is mandatory.
+
+\item {\em areas} or {\em areas.nc}: this file contains mesh surfaces
+for the component model grids in single or double precision {\tt REAL}
+arrays (depending on OASIS3 compilation options). The array names must be
+composed of the grid prefix and the suffix ``.srf''.  The surfaces may
+be given in any units but they must be all the same (in {\tt
+INTERP/GAUSSIAN}, it is assumed that the units are $m^2$ but they are
+used for statistics calculations only.) This file {\em areas} or {\em
+areas.nc} is mandatory for {\tt CHECKIN}, {\tt CHECKOUT} or {\tt
+CONSERV}, and used for statistic calculations in {\tt
+INTERP/GAUSSIAN}; it is not required otherwise.
+
+\item {\em maskr} or {\em maskr.nc}: this file
+  contains Reduced (D) grid mask in {\tt INTEGER} arrays dimensioned
+  {\tt array(nbr\_pts)} where {\tt nbr\_pts} is the total number of the
+  Reduced grid points (0 -not masked- or 1 -masked- for each grid
+  point). This file is required only for grids to which the {\tt
+  REDGLO} or {\tt GLORED} transformation is applied. As mentionned above,
+  these transformations should not be used anymore as interpolations
+  are now available for Reduced grids directly. If used, the mask
+  array name must be ``MSKRDxxx'' where ``xxx'' is half the number of
+  latitude circles of the reduced grid (032 for a T42 for example).
+  
+\end{enumerate}
+
+If the binary format is used, {\em grids}, {\em masks}, {\em areas},
+and {\em maskr} must have the following structure. The array
+name is first written to
+the file to locate a data set corresponding to a given grid.  The
+data set is then written sequentially after its name.  Let us call
+``brick'' the name and its associated data set.  The order in which
+the bricks are written doesn't matter.  All the bricks are written in
+the grid data file in the following way:
+
+\begin{verbatim}
+        ...
+        WRITE(LU) array_name
+        WRITE(LU) auxildata
+        ...\end{verbatim} where
+\begin{itemize}
+\item {\tt LU} is the associated unit,
+\item {\tt array\_name} is the name of the array (CHARACTER*8),
+\item {\tt auxildata} is the REAL or INTEGER array dimensioned {\tt
+  (nx, ny)} or {\tt (nbr\_pts,1)} containing the grid data.
+\end{itemize}
+
+%subsection{Grid data files}
+
+\section{Coupling restart files}
+\label{subsec_restartdata}
+
+At the beginning of a coupled run, some coupling fields may have to be
+initially read from their coupling restart file (see section \ref
+{subsubsec_Algoritms}). If needed, these files are also 
+automatically  updated by the
+last {\tt prism\_put\_proto} call of the run (see section \ref{prismput}) . To
+force the writing of the field in its coupling restart file, one can
+use the routine {\tt prism\_put\_restart\_proto} (see section \ref{subsec:auxiliary}). 
+The name of the coupling restart file is given
+by the 6th character string on the first configuring line for each
+field in the {\em namcouple} (see section
+\ref{subsec_namcouplesecond}). Coupling fields coming from different
+models cannot be in the same
+coupling restart files, but for each model, there can be an arbitrary
+number of fields written in one coupling restart file. Note that in
+the NONE techniques, output files with the same format are also
+created for writing the resulting field after transformation.
+
+In the coupling restart files, the fields must be single or double
+precision REAL arrays (depending on PSMILe and OASIS3 compilation
+options) and, as the grid data files, must be dimensioned {\tt (nx,
+ny)}, where {\tt nx} and {\tt ny} are the grid first and second
+dimension, except for fields given on Unstructured ('U') and Reduced
+('D) grid, for which the arrays are dimensioned {\tt (nbr\_pts,1)},
+where {\tt nbr\_pts} is the total number of grid points.  The shape
+and orientation of each restart field (and of the corresponding
+coupling fields exchanged during the simulation) must be coherent with
+the shape of its grid data arrays. The exceptions are for A, B, G,
+L, Z, or Y grids for which the field may be oriented from North to
+South and/or from East to West, in which case, {\tt INVERT}
+transformation will have to be used - see section
+\ref{subsec_preproc}.
+
+Both binary and NetCDF formats are supported; for NetCDF file the
+suffix .nc is not mandatory. If the coupling restart file
+for the first field is in NetCDF format, OASIS3 will assume that all
+coupling restart files (and output files for {\tt NONE}
+communication techniques) are NetCDF\footnote{Note that even if the grid
+auxiliary data files are in NetCDF format, the restart coupling files
+may be in binary format, or vice-versa.}. 
+
+In the NetCDF restart files, the field arrays must have the source symbolic
+name indicated in the {\em namcouple}
+(see section \ref{subsec_namcouplesecond}).
+
+In binary restart file, each field is written in the following way:
+\begin{verbatim}
+        ...
+        WRITE(LU) array_name
+        WRITE(LU) restartdata
+        ...\end{verbatim} where
+\begin{itemize}
+\item {\tt LU} is the associated unit,
+\item {\tt array\_name} is the source symbolic name of the field (CHARACTER*8),
+\item {\tt restartdata} is the restart field REAL array dimensioned
+  {\tt (nx, ny)} or {\tt (nbr\_pts,1)}\footnote{If REDGLO is the first
+  transformation applied on a Reduced grid field, the Reduced field
+  must be given is an array {\tt restartdata(nx*ny)} where {\tt nx}
+  and {\tt ny} are the global Gaussian grid dimensions and the Reduced
+  field is completed by trailing zeros.}
+\end{itemize}
+
+%subsection{Restart data files}
+
+\section{Input data files}
+\label{subsec_inputdata}
+
+Fields with status {\tt INPUT} in the {\em namcouple} will, at
+  runtime, simply be read in from a NetCDF input file by the target
+  model PSMILe below the {\tt prism\_get\_proto} call, at appropriate
+  times corresponding to the input period indicated by the user in the
+  {\it namcouple}. 
+
+\vspace*{0.5cm}
+ 
+The name of the file must be the one given on the field first
+configuring line in the {\em namcouple} (see section
+\ref{subsubsec_secondINPUT}). There must be one input file per {\tt
+INPUT} field, containing a time sequence of the field in a single or
+double precision REAL array (depending on PSMILe compilation options),
+named with the field symbolic name in the {\em namcouple} and
+dimensioned {\tt (nx,ny,time)} or {\tt (nbr\_pts,1,time)}.  The time
+variable as to be an array {\tt time(time)} expressed in
+``seconds since beginning of run''. The ``time'' dimension has to
+be the unlimited dimension. 
+For a practical example, see the file SOALBEDO.nc in 
+{\tt /prism/data/toyclim/input\_toyclim\_standard\_standard\_prism\_2-2.tar.gz}.
+
+%subsection{Input data files}
+
+\section{Transformation auxiliary data files}
+\label{subsec_transformationdata}
+
+Many transformation need auxiliary data files, such as the
+grid-mapping files used for an interpolation. Some of them are created
+automatically by OASIS3, others have to be generated by the user before
+starting the coupled run.
+
+\subsection{Auxiliary data files for {\tt EXTRAP/NINENN}, 
+{\tt EXTRAP/WEIGHT}, {\tt INTERP/SURFMESH}, {\tt INTERP/GAUSSIAN},
+{\tt MOZAIC}, and {\tt SUBGRID}}
+
+The auxiliary data files containing the weights and addresses used
+in these transformations have a similar structure; their names are
+given in Table \ref{tab.fileana}.
+
+\begin{table}[hbtp]
+\begin{center}
+\begin{tabular}{|l|l|}
+\hline
+File name & Description \\
+\hline
+\hline
+{\em  nweights }& weights, addresses and iteration number for
+EXTRAP/NINENN interpolation  \\
+any name        & weights and addresses for EXTRAP/WEIGHT extrapolation \\
+{\em  mweights }& weights and addresses for INTERP/SURFMESH interpolation  \\
+{\em  gweights }& weights and addresses for INTERP/GAUSSIAN interpolation  \\
+any name        & weights and addresses for MOZAIC interpolation \\
+
+any name        & weights and addresses for SUBGRID interpolation \\
+\hline
+\end{tabular}
+\end{center}
+\caption{Analysis auxiliary data files}
+\label{tab.fileana}
+\end{table}
+
+The files {\em nweights}, {\em mweights} and {\em gweights} can be
+created by OASIS3 if their corresponding {\tt \$NIO} = 1 (see {\tt
+EXTRAP/NINENN, INTERP/SURFMESH, INTERP/GAUSSIAN} in sections
+\ref{subsec_preproc} and \ref{subsec_interp}).
+
+The name of the (sub)grid-mapping files for {\tt MOZAIC,
+EXTRAP/WEIGHT} and {\tt SUBGRID} analyses can be chosen by the user
+and have to be indicated in the {\em namcouple} (see respectively
+sections \ref{subsec_preproc} and \ref{subsec_interp} and
+\ref{subsec_cooking}). These files have to be generated by the user before
+starting the coupled run.
+
+\vspace*{0.5cm}
+ 
+The structure of these files is as follows:
+
+\begin{verbatim}
+      ...
+      CHARACTER*8 cladress,clweight
+      INTEGER iadress(jpnb,jpo)
+      REAL weight(jpnb,jpo)
+      OPEN(unit=90, file='at31topa', form='unformatted')
+      WRITE(clweight,'(''WEIGHTS'',I1)') knumb
+      WRITE(cladress,'(''ADRESSE'',I1)') knumb
+      WRITE (90) cladress
+      WRITE (90) iadress
+      WRITE (90) clweight
+      WRITE (90) weight
+\end{verbatim}
+
+where 
+\begin{itemize}
+\item {\tt jpnb} is the maximum number of neighbors used in the transformation
+({\tt \$NVOISIN} in the {\em namcouple})
+\item {\tt jpo} is the total dimension of the target grid
+\item {\tt at31topa} is the name of the grid-mapping data file ({\tt \$CFILE}
+in  {\em namcouple})
+\item {\tt knumb} is the identificator of the data set ({\tt \$NID} in
+{\em namcouple}) 
+\item {\tt cladress} is the locator of the address dataset
+\item {\tt clweight} is the locator of the weight dataset
+\item {\tt iadress (i,j)} is the address on the source grid of the $i^e$
+neighbor used for the mapping of the $j^e$ target grid point. The
+address is the index of a grid point within the total number of grid
+points.
+\item {\tt weight(i,j)} is the weight affected to the $i^e$
+neighbor used for the transformation of the $j^e$ target grid point
+\end{itemize}
+
+For file {\em nweights}, there is an additional brick composed of a
+{\tt CHARACTER*8} variable (formed by the characters {\tt INCREME} and
+by the data set identificator) and of an {\tt INTEGER array(N)} which
+is the iteration number within {\tt EXTRAP/NINENN} at which the
+extrapolation of the $n^e$ grid point is effectively performed.
+
+\subsection{Auxiliary data files for {\tt FILLING}}
+
+For the FILLING analysis, the global data set used can be
+either interannual monthly, climatological monthly or yearly (see
+\ref{subsec_interp}). The name of the global data file 
+can be chosen by the user and has to be indicated in the {\em namcouple}
+have to be given to OASIS through the input file {\em namcouple}. In case of monthly data, the file 
+must be written in the following way:
+\begin{verbatim}
+      ...
+      REAL field_january_year_01(jpi, jpj)
+      ...
+      WRITE(NLU_fil) field_january_year_01
+      WRITE(NLU_fil) field_february_year_01
+      WRITE(NLU_fil) field_march_year_01
+      etc...
+      WRITE(NLU_fil) field_december_year_01
+C
+C if climatology, one stops here
+C
+      WRITE(NLU_fil) field_january_year_02
+      etc...
+\end{verbatim}
+
+where
+\begin{itemize}
+\item  {\tt field\_...} is the global dataset
+\item {\tt jpi} and {\tt jpj} are the dimensions of the grid on which FILLING
+is performed
+\item {\tt NLU\_fil} is the logical unit associated to the global data file and is
+defined in the input file {\em namcouple}
+\end{itemize}
+Note that the first month needs not to be a january.
+This is the only file within OASIS in which the fields are not read
+using a locator.
+
+\subsection{Auxiliary data files for {\tt SCRIPR}}
+
+The NetCDF files containing the weights and addresses for the {\tt
+  SCRIPR} remappings (see section \ref{subsec_interp})  are
+  automatically generated at runtime by OASIS3. Their structure is
+  described in detail in section 2.2.3 of the SCRIP documentation available
+  in {\tt prism/src/mod/oasis3/doc/SCRIPusers.pdf}.
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG6_Compilation_running.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG6_Compilation_running.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG6_Compilation_running.tex	(revision 1677)
@@ -0,0 +1,339 @@
+\newpage
+%
+
+\chapter{Compiling and running with OASIS3}
+\label{sec_compilationrunning}
+
+OASIS3 and its TOYCLIM coupled model has been successfully compiled
+and run on Fujitsu VPP5000, NEC SX5 and SX6, SGI IRIX64, SGI Origin
+3800, Linux Opteron, IBM Power4, and Cray X1.
+
+\section{Compiling OASIS3 and the TOYCLIM coupled model}
+\label{subsec_compile}
+
+OASIS3 and the TOYCLIM coupled model use the PRISM standard directory
+structure (see also \cite{leg04}) and Standard Compiling Environment (see
+also \cite{gay04}). To
+compile OASIS3 and toyatm, toyoce and toyche component models, one
+should go through the following steps:
+\begin{enumerate}
+\item Go in the directory {\tt prism/util/compile/frames}.
+
+\item Create the include files for your platform if they do not
+already exist in directory \break {\tt
+prism/util/compile/frames/include\_<node>} where {\tt <node>} is the
+name of the platform. 
+
+\item Generate a compile script for the libraries using the script
+Create\_COMP\_libs.frm:
+
+\vspace*{2ex}
+\begin{Frame}
+  \vspace*{1ex}
+  \Unixcmd{Create\_COMP\_libs.frm "" "" "" ""}
+\end{Frame}
+\vspace*{2ex}
+
+The first parameter can be either {\tt ""} or {\tt "-"} to direct the
+standard output to a file or the screen.
+
+The second parameter an be either {\tt ""}, {\tt "-"} or {\tt "+"} to
+direct the standard error to a file, the screen or the standard
+output.
+
+If the compile scripts shall be created for another platform than the
+one where the \break Create\_COMP\_libs.frm script is launched, the third
+parameter has to contain the abbreviated node name ``node".
+
+The compile script for the libraries \texttt{COMP\_libs.$<$node$>$}
+should then be created in the directory \texttt{prism/util}.
+ 
+\item Generate a compile scrip for OASIS3 and for each of the component
+models using the script Create\_COMP\_models.frm:
+\vspace*{2ex}
+\begin{Frame}
+  \vspace*{1ex}
+  \Unixcmd{Create\_COMP\_models.frm oasis3 "mp" "" "" "" }\\
+  \Unixcmd{Create\_COMP\_models.frm toyoce "mp" "" "" "" "ID" "toyatm toyoce toyche"}\\
+  \Unixcmd{Create\_COMP\_models.frm toyatm "mp" "" "" "" "ID" "toyatm toyoce toyche"}\\
+  \Unixcmd{Create\_COMP\_models.frm toyche "mp" "" "" "" "ID" "toyatm toyoce toyche"}
+\end{Frame}
+\vspace*{2ex}
+
+The second parameter ``mp'' specifies the message passing used, which
+determines how the models are launched (see also section
+\ref{subsubsec_Initialisation}).  If the default `MPI2' is chosen, the
+string has to be empty (specification of MPI2 results in an error);
+otherwise, MPI1 has to be given, or NONE for the interpolator only
+mode -see section \ref{subsec_interpolator}.  The OASIS3 executable
+will have the string MPI1 or MPI2 appended to its name. The 3 toy
+models can also be compiled with either the MPI1 option or the default
+MPI2 option (empty string).
+
+The third parameter can be either {\tt ""} or {\tt "-"} to direct the
+standard output to a file or the screen.
+
+The fourth parameter an be either {\tt ""}, {\tt "-"} or {\tt "+"} to
+direct the standard error to a file, the screen or the standard
+output.
+
+If the compile scripts shall be created for another platform than the
+one where the \break Create\_COMP\_models.frm script is launched, the fifth
+parameter has to contain the abbreviated node name ``node".
+
+The sixth parameter ``ID'' is version acronym for differentiation of
+executables (not relevant for OASIS3 and TOYCLIM toy models).
+
+Finally the last parameter gives the name of all the component models
+in the coupled constellation. This list is not relevant for OASIS3,
+but it has to be given for the toymodels. The specified partner models
+are checked against allowed partners and no default is set.
+
+The scripts to compile OASIS3 and the 3 toy coupled models,
+\texttt{COMP\_oasis3\_<mp>.<node>}
+\texttt{COMP\_toyatm\_<ID>.<node>}, \texttt{COMP\_toyoce\_<ID>.<node>},
+\texttt{COMP\_toyche\_<ID>.<node>} should then be created, respectively in
+directories \texttt{prism/src/mod/oasis3}, \texttt{ /toyatm},
+\break \texttt{ /toyoce}, \texttt{ /toyche}. 
+
+\item The compilation scripts created can now be used to compile
+OASIS3 and the 3 toy models. All four compile scripts have then to be
+launched explicitely by the user in their respective directory. 
+\vspace*{2ex}
+\begin{Frame}
+  \vspace*{1ex}
+  \Unixcmd{COMP\_oasis3\_<mp>.<node>}\\
+  \Unixcmd{COMP\_toyatm\_<ID>.<node>}\\
+  \Unixcmd{COMP\_toyoce\_<ID>.<node>}\\
+  \Unixcmd{COMP\_toyche\_<ID>.<node>}
+\end{Frame}
+\vspace*{2ex}
+
+The scripts compile the models with the MPI library specified during
+their generation.  The script that triggers the update of the
+libraries, \texttt{COMP\_libs.$<$node$>$}, is automatically called by
+the model compilation scripts for the librairies they need. Libraries
+needed by OASIS3 are anaisg, anaism, scrip, fscint, and clim for MPI1
+and MPI2 mode (clim is not compiled in NONE mode). The toy
+models need psmile and mpp\_io.
+ 
+\item The result should be executables {\tt oasis3.<mp>.x}, {\tt
+toyatm.<mp>.x}, {\tt toyoce.<mp>.x}, and {\tt toyche.<mp>.x} in the
+{\tt \$BLDROOT/bin} directory defined by the compile scripts, where
+{\tt <mp>} is either MPI1 or MPI2.
+
+\end{enumerate}
+
+\section{Configuring the TOYCLIM coupled model using OASIS3}
+\label{subsec_configuring}
+
+The TOYCLIM coupled model performs a coupling between an ``empty" ocean
+model, toyoce, an``empty" atmospheric model, toyatm, and an ``empty"
+atmospheric chemistry model, toyche. There is no real physics or
+dynamics within the models. However, the coupling fields have a
+realistic size, the operations performed within OASIS3 on the coupling
+fields are realistic, and the coupling using the PRISM System
+model interface (PSMILe) is also realistic.  The TOYCLIM atmosphere
+and chemistry models have the same grid and the same parallel
+partitioning on 3 processes. There is no need of interpolation and
+the coupling fields are directly exchanged between these two models
+without going through OASIS3 interpolation process. More details on
+the TOYCLIM coupled model can be found in \cite{val04b}.
+
+The TOYCLIM coupled model uses PRISM standard running environment
+(SRE). To run it, one has to go through the following
+steps: 
+
+\begin{enumerate}
+\item Go to the directory {\tt prism/util/running/frames}
+\item Create the include files for your platform if they do not
+already exist in directory {\tt
+prism/util\break/running/frames/include\_<node>} where {\tt <node>} is
+the name of the platform.
+\item Run the script Create\_TASKS.frm to generate a setup file for
+your TOYCLIM experiment:
+
+\begin{Frame}
+ \begin{Indent}
+  \vspace*{1ex}
+  \Unixcmd{Create\_TASKS.frm toyclim <expid>}
+ \end{Indent}
+\end{Frame}
+\vspace*{2ex}
+
+where {\tt <expid>} is your experiment name.
+
+\item To change the configuration of your experiment, modify the
+values of the configurable entries in the setup file {\tt
+prism/util/running/frames/setup/setup\_toyclim\_<expid>}, which
+contains default values for these entries. Some of these configurable
+entries directly enter the OASIS3 configuration file {\it namcouple},
+other affect the running script only\footnote{Additional {\it
+namcouple} entries are also configurable by editing directly the
+namcouple base file. Refer to chapter \ref{sec_namcouple} for more
+details.}.  The {\it namcouple} file is created from the {\it
+namcouple} base file (see \texttt{namcouple\_toyclim} in
+\texttt{prism/util/running\break/adjunct\_files/oasis3}) by replacing the
+configurable entries (which begin with "\#") by the value defined in
+the setup file.  The {\it namcouple} will be read by OASIS3 at
+runtime. The variables that can be defined in the set-up file and
+correspond to configurable {\it namcouple} entries are the following:
+ 
+\begin{enumerate}
+
+\item{\em jobname}: Experiment identifier; it is composed of three
+ digits; ({\em \#Jobname}).
+ 
+\item{\em nlogprt}: Integer controlling the amount of information
+ written to the OASIS output file {\em cplout}. 0: minimum output, 1:
+ medium output, 2: maximum output; ({\em \#Nlogprt}).
+
+\item{\em extrapwr}: Flag to provoke the calculation of weights and
+ addresses for nearest neighbour extrapolation (EXTRAP/NINENN) within
+ OASIS3 (1) or to read them from file (0); ({\em \#Extrapwr}).
+
+\item{\em stat\_field{\bf xx}}, where {\bf xx} is the number of the
+field in the namcouple: The status of the {\bf xx} coupling/IO field
+can be either `EXPOUT' or `EXPORTED', except for $Field_3$ for which
+it is `INPUT', for $Field_5$ for which it is `OUTPUT' and for
+$Field_{10}$ and $Field_{11}$ for which it is either `IGNOUT' or
+`IGNORED' (see section \ref{subsec_namcouplesecond}); ({\em
+\#Stat\_field{\bf xx}}).
+
+\item{\em dtF{\bf xx}}, where {\bf xx} is the number of the field in
+the namcouple: The coupling or I/O period of the {\bf xx} coupling/IO field,
+which must be a multiple of 14400, except for $Field_3$ for which it
+must be a multiple of 43200, and for $Field_5$, $Field_{10}$ and
+$Field_{11}$ for which it must be a multiple of 3600; ({\em \#Dt{\bf
+xx}}).
+
+\item {\em iniyear}, {\em inimonth} and {\em iniday}: the initial date
+of the experiment, respectively as {\tt YYYY}, {\tt MM} and {\tt
+DD}({\em \#Inidate}).
+
+\item {\em message\_passing}: Message passing method, either MPI2 or
+  MPI1 (for more details, see section \ref{subsubsec_Initialisation});
+  (in {\em \#Channel})
+
+\item {\em bsend}: either `yes' or `no', indicates whether the
+ buffered {\tt MPI\_BSend} or the standard blocking send {\tt
+ MPI\_Send} will be used to send the coupling fields (for more
+ details, see section \ref{subsec_namcouplefirst}) (in {\em \#Channel})
+
+\end{enumerate}
+
+The variables that can be additionally defined in the setup file but
+do not correspond to any
+configurable {\it namcouple} entries are the following:
+ 
+\begin{enumerate}
+
+\item {\em ncplvers}: the namcouple version. Put {\tt ""} to use the
+  {\it namcouple} base file completed with the values defined in the
+  setup file. To use another {\it namcouple}, a particular value has
+  to be given to {\em ncplvers}, and a {\it namcouple} named
+  {\tt namcouple\_toyclim\_$<$ncplvers$>$} has to be available in
+  \texttt{prism/util/running/adjunct\_files/oasis3}.
+
+\item{\em gridswr}: either `0' if you want the models to use the grid
+  description files if they exist, or `1' if you want the models to
+  unconditionally (re)generate those grid description files (for more
+ details, see section \ref{subsubsec_griddef}).
+
+\end{enumerate}
+
+\item Type {\tt `Create\_TASKS.frm toyclim <expid>'} a second
+time. The script will check the parameters you specified in
+{\tt setup\_toyclim\_<expid>}. If a parameter is not supported or a
+combination of parameters does not make sense Create\_TASKS.frm writes
+an error message and stops.
+\item Correct the experimental setup file if necessary and
+run Create\_TASKS.frm again until the setup check is passed
+successfully.
+
+\end{enumerate}
+
+Once the setup is done, all appropriate files and the script to start
+the experiment are available in the
+directory {\tt $<$home$>$/$<$expid$>$}, where {\tt $<$home$>$} and
+{\tt $<$expid$>$} are
+defined in the setup file.
+
+\section{Running the TOYCLIM coupled model using OASIS3}
+\label{subsec_running}
+
+After the setup and configuration phase, the experiment is ready to be
+started with the running script {\tt RUN\_toyclim\_<expid>} in
+directory {\tt $<$work$>$/$<$expid$>$/scripts}, where {\tt $<$work$>$} and
+{\tt $<$expid$>$} are
+as defined in the setup file {\tt setup\_toyclim\_<expid>}.
+
+To run a TOYCLIM experiment, one has to go through the following
+steps:
+
+\begin{enumerate} 
+%\item The file {\tt
+%  toyclim/input\_toyclim\_standard\_\-standard\_prism\_2-1.tar.gz} has
+%  to be copied from the directory {\tt prism/data} to the directory
+%{\tt <archive\_in>/toyclim} on the \break {\tt <archiving\_host>}.  The variables
+%{\tt <archive\_in>} and {\tt <archiving\_host>} are specified in the setup file .
+\item Login on the compute server (if different from the compile server).
+\item Change to the directory {\tt <work>/<expid>/scripts}. 
+\item Submit the runscript {\tt RUN\_toyclim\_<expid>}.
+\end{enumerate}
+
+Running TOYCLIM with the default parameters will result in a 30-day
+experiment executed as five 6-day runs. The final results obtained the
+directory {\tt <work>/<expid>/work} should match the ones in {\tt
+prism/data/toyclim/outdata}. Intermediate results are also saved in
+different sub-directories :
+\begin{itemize} 
+ \item the OASIS3 log files of each
+run in {\tt <data>/<expid>/log } or {\tt  <archive>/<expid>/log }
+ \item the output netCDF files containing the {\tt EXPOUT} fields in {\tt
+<data>/<expid>/outdata/oasis3 } or {\tt
+ <archive>/<expid>/outdata/oasis3 }
+\item the coupling restart files in {\tt  <data>/<expid>/restart } or
+  {\tt  <archive>/<expid>/restart}.
+\end{itemize}
+where {\tt <data>} and {\tt <archive>} are
+defined in the runscript {\tt RUN\_toyclim\_<expid>}.
+
+\section{Running the TOYCLIM coupled model manually}
+\label{subsec_runningmanually}
+
+If you want to run the TOYCLIM manually, you need to copy the
+following files in your working directory:
+\begin{itemize}
+\item OASIS3, toyatm, toyoce, toyche executables
+\item OASIS3 grid, restart, and auxiliary files: grids.nc, masks.nc,
+ areas.nc, SOALBEDO.nc, flda1.nc, flda2.nc, flda3.nc,
+ flda4.nc, fldo1.nc, at31topa, runoff31, which are in
+{\tt  prism/data/toyclim\break/input\_toyclim\_standard\_standard\_prism\_2-2.tar.gz}
+\item OASIS3 adjunct files `cf\_name\_table.txt' and `namcouple' which can be
+ found under names \break `cf\_name\_table.txt' and
+ `namcouple\_toyclim\_use' in {\tt prism/util/running/adjunct\_files\break/oasis3}
+\end{itemize}
+Then you need to start the coupled model, setting up MPI parameters
+properly. For examples, refer to files {\tt config\_site\_<node>.h} and
+{\tt launching\_toyclim\_<node>.h} in {\tt
+prism/util/running\break/frames/include\_<node>} (where {\tt <node>} is the
+name of the platform).  
+
+\section{Running OASIS3 in interpolator-only mode}
+
+To run OASIS3 in interpolator-only mode, one has to go through the
+following steps (the following specific files can be
+retrieved from CERFACS CVS only):
+\begin{itemize}
+\item Compile OASIS3 following the procedure described in section
+\ref{subsec_compile} specifying {\tt NONE} as {\tt <mp>}.
+\item Compile the programs that will calculate the
+interpolation error fields, i.e. gen\_error.f90 and \break gen\_error\_vector.f90 in directory {\tt prism/util/running/testinterp/error}. 
+\item Execute the
+running script {\tt prism/util/running/testinterp/sc\_run\_testinterp}. 
+\item The results obtained after running the TOYCLIM with the defaults
+parameters should match the ones in {\tt prism/data/testinterp/outdata}.
+\end{itemize}
+For more details, please read the {\tt
+prism/util/running/testinterp/README\_testinterp}.
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UGA1_Grid_description.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UGA1_Grid_description.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UGA1_Grid_description.tex	(revision 1677)
@@ -0,0 +1,97 @@
+\newpage
+\appendix
+\chapter{The grid types for the transformations}
+\label{subsec_gridtypes}
+
+As described in section \ref{sec_transformations}, the different
+transformations in OASIS3 support different types of grids. The
+characteristics of these grids are detailed here.
+
+\begin{enumerate}
+
+\item Grids supported for the {\tt INTERP}
+    interpolations (see section \ref{subsec_interp})
+
+\begin{itemize}
+ 
+\item {\tt `A' grid}: this is a regular Lat-Lon grid covering either
+      the whole globe or an hemisphere, going from South to North and
+      from West to East.  There is no grid point at the
+      pole and at the equator, and the first latitude has an offset of
+      0.5 grid interval. The first longitude is 0$^o$ (the Greenwhich
+      meridian) and is not repeated at the end of the grid ({\tt
+      \$CPER} = P and {\tt \$NPER}= 0).  The latitudinal grid length
+      is 180/NJ for a global grid, 90/NJ otherwise. The longitudinal
+      grid length is 360/NI. 
+
+\item {\tt `B' grid}: this is a regular Lat-Lon grid covering either
+      an hemisphere or the whole globe, going from South to North and
+      from West to East. There is a grid point at the
+      pole and at the equator (if the grid is hemispheric or global
+      with NJ odd). The first longitude is 0$^o$ (the Greenwhich
+      meridian), and is repeated at the end of the grid ({\tt \$CPER}
+      = P and {\tt \$NPER}= 1).  The latitudinal grid length is
+      180/(NJ-1) for a global grid, 90/(NJ-1) otherwise. The
+      longitudinal grid length is 360/(NI-1). 
+
+  
+\item {\tt `G' grid}: this is a irregular Lat-Lon Gaussian grid
+covering either an hemisphere or the whole globe, going from South to
+North and from West to East. This grid is used in spectral models. It
+is very much alike the A grid, except that the latitudes are not
+equidistant. There is no grid point at the pole and at the
+equator. The first longitude is 0$^o$ (the Greenwhich meridian) and is
+not repeated at the end of the grid ({\tt \$CPER} = P and {\tt
+\$NPER}= 0).  The longitudinal grid length is 360/NI.  
+
+
+\item {\tt `L' grid}: this type covers regular Lat-Lon grids in
+      general, going from South to
+North and from West to East.. The grid can be described by the latitude and the
+      longitude of the southwest corner of the grid, and by the
+      latitudinal and longitudinal grid mesh sizes in degrees.
+
+\item {\tt `Z' grid}: this is a Lat-Lon grid with non-constant
+      latitudinal and longitudinal grid mesh sizes, going from South to
+North and from West to East. The deformation of
+      the mesh can be described with the help of 1-dimensional
+      positional records in each direction. This grid is periodical
+      ({\tt \$CPER} = P) with {\tt \$NPER} overlapping grid points.
+
+\item {\tt `Y' grid}: this grid is like `Z' grid except that it is 
+      regional ({\tt \$CPER} = R and {\tt \$NPER} = 0).
+  
+ \end{itemize}
+
+\item Grids supported for the {\tt SCRIPR} interpolations
+
+\begin{itemize}
+
+\item {\tt `LR' grid}: The longitudes and the latitudes of
+  2D Logically-Rectangular (LR) grid points can be described by two arrays
+  {\tt longitude(i,j)} and {\tt latitude(i,j)}, where i and j
+  are respectively the first and second index dimensions. Streched
+  or/and rotated grids are LR grids. Note that A, B, G, L, Y, or Z
+  grids are all particular cases of LR grids.
+
+\item {\tt `U' grid}: Unstructured (U) grids do have any particular
+      structure. The longitudes and the latitudes of 2D Unstructured
+      grid points must be described by two arrays {\tt
+      longitude(nbr\_pts,1)} and {\tt latitude(nbr\_pts,1)}, where nbr\_pts
+      is the total grid size.
+
+\item {\tt `D' grid} The Reduced (D) grid is composed of a certain
+number of latitude circles, each one being divided into a varying
+number of longitudinal segments. In OASIS3, the grid data (longitudes,
+latitudes, etc.) must be described by arrays dimensioned {\tt
+(nbr\_pts,1)}, where {\tt nbr\_pts} is the total number of grid
+points. There is no overlap of the grid, and no grid point at the
+equator nor at the poles. There are grid points on the Greenwich
+meridian.
+ 
+\end{itemize}
+
+\end{enumerate}
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UGA2_SCRIP.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UGA2_SCRIP.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UGA2_SCRIP.tex	(revision 1677)
@@ -0,0 +1,62 @@
+\newpage
+
+\chapter{Copyright statements}
+
+\section{OASIS3 copyright statement}
+
+Copyright © 2004 Centre Europ\'een de Recherche et Formation
+Avanc\'ee en Calcul Scientifique (CERFACS).  
+
+This software and ancillary information called OASIS3 is free
+software.  CERFACS has rights to use, reproduce, and distribute
+OASIS3. The public may copy, distribute, use, prepare derivative works and
+publicly display OASIS3 under the terms of the Lesser GNU General
+Public License (LGPL) as published by the Free Software Foundation,
+provided that this notice and any statement of authorship are
+reproduced on all copies. If OASIS3 is modified to produce derivative
+works, such modified software should be clearly marked, so as not to
+confuse it with the OASIS3 version available from CERFACS.
+
+The developers of the OASIS3 software attempt to
+build a modular and user-friendly coupler for to the climate
+modelling community. The software is provided for free; in return,
+the user assumes full responsibility for use of the software. The
+OASIS3 software comes without any warranties (implied or expressed) and
+is not guaranteed to work for you or on your computer. Specifically,
+CERFACS and the various individuals involved in development and
+maintenance of the OASIS3 software are not responsible for any damage
+that may result from correct or incorrect use of this software.
+
+If you feel that your research has benefited from the use of the OASIS3
+software, we will greatly appreciate your reference to the following 
+report:
+
+{\tt Valcke, S., A. Caubel, R. Vogelsang, D. Declat, 2004. OASIS3 User Guide (oasis3\_prism\_2-4). PRISM Report Series No 2,
+5th Ed., 60 pp.}
+
+\section{The SCRIP 1.4 copyright statement}
+\label{sec_SCRIP}
+
+The SCRIP 1.4 copyright statement reads as follows:
+
+ ``Copyright © 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 Los Alamos National Laboratory
+under Contract No. W-7405-ENG-36 with the United States Department of
+Energy. The United States Government has rights to use, reproduce, and
+distribute this SOFTWARE. The public may copy, distribute, prepare
+derivative works and publicly display 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.''
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UGA3_couplings.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UGA3_couplings.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UGA3_couplings.tex	(revision 1677)
@@ -0,0 +1,115 @@
+\newpage
+
+\chapter{The coupled models realized with OASIS}
+\label{sec_couplings}
+
+Here is a list of (some of) the coupled models realized with OASIS
+within the past 5 years or so in Europe and in other institutions
+in the world:
+
+\vspace*{3cm}
+
+\begin{table}[hbtp]
+\begin{center}
+\begin{tabular}{|l|l|l|l|l|l|}
+\hline
+Lab & Cnt & Vrs & Atm & Oce & Comp \\
+\hline
+\hline
+IRI     & USA & 2.4 & ECHAM4             & MOM3            & SGI Origin \\
+        &     &     &                    &                 & IBM Power3\\
+\hline
+JPL(NASA) & USA & 2.4 & QTCM             & Trident            & SGI \\
+\hline
+JAMSTEC	& Jp  & 2.4 & ECHAM4	         & OPA 8.2	   & ES SX5 \\
+\hline
+U. of & Aus- & 3.0 & Data atm. model & MOM4         & SGI O3400\\
+Tasmania & tral.     &     &                    &                 & Compaq \\
+\hline
+BMRC	& Aus-    & 3.0 & BAM4         & MOM4            &        \\	
+        & tral.          & 2.4 & BAM3 T47L34	 & ACOM2 180X194X25&        \\	
+\hline
+CAS-IIT & India	    & 3.0 & MM5          & POM             &        \\
+\hline
+\hline	
+\end{tabular}
+\end{center}
+\caption{List of couplings realized with OASIS within the past 5 years
+in institutions outside Europe . The columns list the institution, the
+country, the OASIS version used, the atmospheric model, the ocean
+model, and the computing platform used for the coupled model run.}
+\label{tab.couplingsworld}
+\end{table}
+
+
+\begin{table}[hbtp]
+\begin{center}
+\begin{tabular}{|l|l|l|l|l|l|}
+\hline
+Lab & Cnt & Vrs & Atm & Oce & Comp \\
+\hline
+\hline
+IPSL & Fr & 3.0 & LMDz 96x71x19 & ORCA2 182x149x31 & SX6 \\
+     &    &     & \-+ ORCH/INCA & + LIM            &     \\
+     &    & 2.4 & LMDz 96x71x19 & ORCA2 182x149x31 & VPP5000 \\
+     &    & 2.4	& LMDz 72x45x19	& ORCA4  92x76x31  & VPP5000 \\
+     &    & 2.4 & LMDZ 120X90X1	& OPA ATL3 1/3 deg &         \\
+     &    & 2.4 & LMDZ 120X90X1	& OPA ATL1 1 deg   &         \\
+\hline
+Lodyc& Fr & 2.2 & IFS Tl95 L31	& OPA 8.1          &         \\
+\hline
+Lodyc-ISAO & Fr,It& 2.3 & ECHAM4 T30/T42 L14 & ORCA2 182x149x31 & SX4,SX5\\
+\hline
+M\'et\'eo-Fr & Fr & 3.0 & ARPEGE 4       & ORCA2            & VPP5000\\
+     &        & 2.4 & ARPEGE medias  & OPA med 1/8e     & VPP5000\\
+     &        &	2.2 & ARPEGE 3       & OPA 8.1 + Gelato & VPP5000\\
+     &        &	2.1 & ARPEGE 2 T31L19& OPA8 TDH	        & CRAY J90\\
+\hline
+Mercator & Fr & 3.0 &interp. mode& PAM (OPA)&         \\
+\hline 
+CERFACS & Fr  & 2.4 & ARPEGE 3       & ORCA2-LIM        & VPP5000\\
+        &     &	2.2 & ARPEGE 3       & OPA 8.1          & VPP700 \\
+        &     &	2.1 & ARPEGE 2       & OPAICE	        & CRAY C90 \\
+\hline 					
+ECMWF   & UK  & 2.2 & IFS T63/T255   & E-HOPE 2deg/1deg & IBM Power 4 \\
+        &     &	2.2 & IFS Cy23r4 T159L40 & E-HOPE 256L29& VPP700  \\
+        &     &	2.2 & IFS Cy23r4 T95L40  & E-HOPE 256L29& VPP700  \\
+        &     &	2.0 & IFS Cy15r8 T63L31  & E-HOPE 128L20& VPP300  \\
+\hline
+MPI     & Ger-  & 3.0 & ECHAM5	         & MPI-OM	& IBM Power4\\
+        & ma-    &	2.4 & ECHAM5 T42/L19	 & C-HOPE T42+L20 & NEC-SX \\
+        & ny    &	2.4 & PUMAT42/L19        & C-HOPE 2deg GIN& NEC-SX \\
+        &     &	2.4 & EMAD	         & E-HOPE T42+L20 & CRAY C-90 \\
+        &     &	2.4 & ECHAM5 T42/L19     & E-HOPE T42+L20 & NEC-SX \\
+        &     &	2.2 & ECHAM4 T30/L19     & E-HOPE T42+L20 & CRAY T90 \\
+        &     &	2.2 & ECHAM4 T30/L19     & E-HOPE T42+L20 & CRAY C90 \\
+\hline
+CGAM	& UK  & 3.0 & HadAM3 2.5x3.75 L20 & ORCA2 182x149x31 & NEC SX6\\
+        &     &	2.4 & HadAM3 2.5x3.75 L20 & ORCA 182x149x31  & T3E   \\
+\hline
+SMHI	& Sw  &	3.0 & ECHAM-RCA(reg.)       &                & SGI O3800\\
+        &     &	2.3 & RCA-HIRLAM (reg.)   & RCO-OCCAM (reg.)&   \\	
+\hline
+INGV	& It  & 3.0 & ECHAM5              & MPIOM	    & NEC SX6 \\
+\hline
+KNMI	& Nl  & 3.0 & ECHAM5              & MPIOM           & SGI IRIX64 \\
+\hline
+DMI	& Dk  & 3.0 & ECHAM (glob.)      &                 & NEC SX6 \\
+        &     &     &  \- - HIRLAM (reg.)&                 & \\
+\hline
+U.Bergen& Nw  & 3.0 & MM5                & ROMS	           & \\
+\hline
+SOC     & UK  & 2.2 & Interm. Atm. GCM	 & OCCAM-Lite      & \\	
+\hline
+\hline					
+\end{tabular}
+\end{center}
+\caption{List of couplings realized with OASIS within the past 5 years
+in Europe. The columns list the institution, the country, the OASIS
+version used, the atmospheric model, the ocean model, and the
+computing platform used for the coupled model run.}
+\label{tab.couplingseurope}
+\end{table}	
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UGA4_changes.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UGA4_changes.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UGA4_changes.tex	(revision 1677)
@@ -0,0 +1,307 @@
+\newpage
+
+\chapter{Changes between versions}
+\label{sec_changes}
+
+Here is a list of changes between the different official OASIS3
+versions.
+\section{Changes between {\tt prism\_2\_4} and {\tt
+oasis3\_prism\_2\_3}}
+
+The changes between versions tagged {\tt prism\_2\_4}
+and {\tt oasis3\_prism\_2\_3} delivered
+in July 2004 are the following:
+
+\begin{itemize}
+
+\item Update of compiling and running environments with version
+  \texttt{prism\_2-4} of PRISM Standard Compiling Environment (SCE) and
+  PRISM Standard Running Environment (SRE), which among other
+  improvements include the environments to compile and run on the CRAY
+  X1 (see the directories with \texttt{<node>=baltic1}), thanks to
+  Charles Henriet from CRAY France, and on a Linux station from
+  Recherche en Pr\'evision Num\'erique (Environnement Canada, Dorval,
+  Canada) (see the directories with \texttt{<node>=armc28}).
+
+\item \texttt{prism/src/mod/oasis3/src/iniiof.F}: the opening of the
+  coupling restart files is done only if the corresponding field has a
+  lag greater than 0; note that this implies that all fields in mode
+  NONE must now have a lag greater than 0 (e.g. LAG=+1) (thanks to
+  Veronika Gayler from M\&D).
+
+\item \texttt{prism/src/lib/psmile/src/prism\_def\_var\_proto.F}:
+ contrary to what was previously described in the documentation,
+ \texttt{PRISM\_Double} is not supported as $7^{th}$ argument to
+ describe the field type; {\tt PRISM\_Real} must be given for single
+ or double precision real arrays.
+
+\item \texttt{prism/src/mod/oasis3/src/inipar.F90}: For upward
+   compatibility of SCRIPR interpolation, ``VECTOR" is still accepted
+   in the namcouple as the field type 
+   and leads to the same behaviour as before (i.e. each vector
+   component is treated as an independent scalar field). To have a
+   real vector treatment, one has to indicate "VECTOR\_I" or "VECTOR\_J"
+   (see section \ref{subsec_interp}).
+
+\item Bug corrections in: 
+\begin{itemize}
+
+\item \texttt{prism/src/lib/scrip/src/scriprmp\_vector.F90}: In some
+ cases, some local variables were not deallocated and variable
+ \texttt{dimid} was declared twice.
+
+\item 
+\texttt{prism/src/lib/psmile/src/mod\_psmile\_io.F90}: correct
+allocation of array hosting the longitudes (thanks to Reiner Vogelsang
+from SGI Germany).
+
+\item
+\texttt{prism/src/lib/psmile/src/write\_file.F90}: to remove a deadlock
+on some architecture (thanks to Luis Kornblueh from MPI).
+
+\item
+\texttt{prism/src/lib/psmile/src/prism\_enddef\_proto.F}: the error
+handler is now explicitely set to \texttt{MPI\_ERRORS\_RETURN} before
+the call to \texttt{MPI\_Buffer\_Detach} to avoid abort on some
+architecture when the component model is not previously attached to
+any buffer (thanks to Luis Kornblueh from MPI). 
+
+
+
+\item 
+  \texttt{prism/src/lib/scrip/src/remap\_conserv.f} (thanks to Veronika
+  Gayler from M\&D).
+
+\item \texttt{prism/src/mod/oasis3/src/inicmc.F}
+
+\item \texttt{prism/src/lib/scrip/src/remap\_distwgt.f}
+
+\end{itemize}
+
+\end{itemize}
+
+\section{Changes between {\tt oasis3\_prism\_2\_3} and {\tt
+oasis3\_prism\_2\_2}}
+
+The changes between versions tagged {\tt oasis3\_prism\_2\_3}
+delivered in July 2004 and {\tt oasis3\_prism\_2\_2} delivered
+in June 2004 are the following:
+
+\begin{itemize}
+
+\item Bug correction of the previous bug fix regarding ordering of grid and
+data information contained in I/O files when {\tt INVERT} or {\tt
+REVERSE} transformations are used: the re-ordering now occurs only for
+source field if {\tt INVERT} is used, and only for target field if
+{\tt REVERSE} is used.
+
+\item LGPL license: OASIS3 is now officially released under a Lesser GNU General Public
+License (LGPL) as published by the Free Software Foundation
+(see {\tt prism/src/mod/oasis3/COPYRIGHT} and {\tt prism/src/mod/oasis3/src/couple.f})
+
+\item Upgrade of compiling and running environments: The compiling and
+running environments have been upgraded to the PRISM Standard
+Compiling and Running Environment version dated August 5th
+2004, that should be very close to ``prism\_2-3''.
+
+\item Treament of vector fields: The interpolation algorithms using the SCRIP library now support
+vector fields, including automatic rotation from local to geographic
+coordinate system, projection in Cartesian coordinate system and
+interpolation of 3 Cartesian components, and support of vector
+components given on different grids. New routines have been added in
+{\tt prism/src/lib/scrip/src}: {\tt scriprmp\_vector.F90} and {\tt rotations.F90}.
+For more detail, see {\tt SCRIPR} in section \ref{subsec_interp}.
+
+\item All include of mpif.h are now written `\#include $<$mpif.h$>$'.
+
+\item The output format of {\tt CHECKIN} and {\tt CHECKOUT} results
+is now E22.7
+
+\end{itemize}
+
+\section{Changes between {\tt oasis3\_prism\_2\_2} and {\tt
+oasis3\_prism\_2\_1}}
+
+The changes between versions tagged {\tt oasis3\_prism\_2\_2}
+delivered in June 2004 and {\tt oasis3\_prism\_2\_1} delivered to
+PRISM in April 2004 are the following:
+
+\begin{itemize}
+
+\item Bug corrections
+
+ \begin{itemize}
+
+ \item {\tt INTERP/GAUSSIAN} and {\tt SCRIPR/GAUSWGT} transformations
+ work for `U' grids.
+
+ \item The grid and data information contained in I/O files output by
+ the PSMILe library have now a coherent ordering even if {\tt INVERT}
+ or {\tt REVERSE} transformations are used.
+
+ \end{itemize}
+
+\item OASIS3 and the TOYCLIM coupled model are ported to IBM Power4 and
+Linux Opteron, which are now included in the Standard Compiling and
+Running Environments (SCE and SRE).
+
+\item SIPC technique communication is re-validated.
+
+\item {\tt Clim\_MaxSegments = 338} in {\tt
+prism/src/lib/clim/src/mod\_clim.F90} and in {\tt
+prism/src/lib/psmile/src/mod\_prism\_proto.F90}. 338 is presently the largest
+value needed by a PRISM model. 
+
+\item {\tt MPI\_BSend}: below the call to {\tt prism\_enddef\_proto},
+the PSMILe tests whether or not the model has already attached to an
+MPI buffer. If it is the case, the PSMILe detaches from the buffer,
+adds the size of the pre-attached buffer to the size needed for the
+coupling exchanges, and reattaches to an MPI buffer. The model own
+call to {\tt MPI\_Buffer\_Attach} must therefore be done before the
+call to {\tt prism\_enddef\_proto}. Furthermore, the model is not
+allowed to call {\tt MPI\_BSend} after the call to {\tt
+prism\_terminate\_proto}, as the PSMILe definitively detaches from the
+MPI buffer in this routine. See the example in the toyatm model in
+{\tt prism/src/mod/toyatm/src}.
+
+\end{itemize}
+
+\section{Changes between {\tt oasis3\_prism\_2\_1} and {\tt
+oasis3\_prism\_1\_2}}
+
+The changes between versions tagged {\tt oasis3\_prism\_1\_2}
+delivered in September 2003 and {\tt oasis3\_prism\_2\_1} delivered to
+PRISM in April 2004 are the following:
+
+\begin{itemize}
+
+\item Bug corrections
+
+ \begin{itemize}
+
+ \item Thanks to Eric Maisonnave, a bug was found and corrected in
+  \- \- \- \- \- \- \- \- 
+  /prism/src/lib/scrip/src/scriprmp.f:
+  ``sou\_mask'' and ``tgt\_mask'' were not properly initialised if weights
+  and addresses were not calculated but read from file.
+
+ \item Some deallocation were missing in prism\_terminate\_proto.F
+  (``ig\_def\_part'', ``ig\_length\_part'', ``cg\_ignout\_field'').
+
+ \item Thanks to Arnaud Caubel, a bug was found and corrected in 
+  \- \- \- \- \- \- \- \- /prism/src/lib/psmile/src/write\_file.F90. In case of parallel
+  communication between a model and OASIS3 main process, the binary
+  coupling restart files were not written properly (NetCDF coupling
+  restart files are OK).
+
+ \end{itemize} 
+
+\item Routines renamed
+
+The routines {\tt preproc.f, extrap.f, iniiof.f} in {\tt
+prism/src/mod/oasis3/src} were renamed to {\tt preproc.F, extrap.F,
+iniiof.F}, as a CPP key `key\_openmp' was added. Please note that this
+key, allowing openMP parallelisation, is not fully tested yet.
+
+\item Modifications in the namcouple
+
+\begin{itemize}
+\item The third entry on the field first line now corresponds to an index in
+the new auxiliary file {\em cf\_name\_table.txt} (see sections
+\ref{subsec_namcouplesecond} and \ref{subsec_cfnametable}).
+
+\item For {\tt IGNORED, IGNOUT} and {\tt OUTPUT} fields, the source
+and target grid locator prefixes must now be given on the field second
+line (see section \ref{subsubsec_secondIGNORED})
+\end{itemize}
+
+\item A new auxiliary file {\em cf\_name\_table.txt}
+
+For each field, the CF standard name used in the OASIS3 log file, {\em
+cplout}, is now defined in an additional auxiliary file {\em
+cf\_name\_table.txt} 
+% (see the file in \- {\tt prism/data/toyclim/input})XXXX, 
+not in {\tt inipar.F} anymore. This auxiliary file must be
+copied to the working directory at the beginning of the run. The user
+may edit and modify this file at her own risk. In {\em
+cf\_name\_table.txt}, an index is given for each field standard name
+and associated units.  The appropriate index has to be indicated for
+each field in the {\em namcouple} (third entry on the field first
+line, see section \ref{subsec_namcouplesecond}). 
+
+This standard name and the associated units are also used to define the
+field attributes ``long\_name'' and ``units'' in the NetCDF output files
+written by the PSMILe for fields with status {\tt EXPOUT, IGNOUT} and
+{\tt OUTPUT}.
+ 
+For more details on this auxiliary file, see section
+\ref{subsec_cfnametable}.
+
+\item Many timesteps for mode NONE
+
+In mode NONE, OASIS3 can now interpolate at once all time occurrences
+of a field contained in an input NetCDF file. The time variable in the
+input file is recognized by its attribute ``units''. The acceptable
+units for time are listed in the udunits.dat file \cite{udunits}. This
+follows the CF convention.
+
+The keyword {\tt \$RUNTIME} in the namcouple has to be the number of time
+occurrences of the field to interpolate from the input file. The
+``coupling'' period of the field (4th entry on the field first line)
+must be always ``1''. Note that if {\tt \$RUNTIME} is smaller than the
+total number of time ocurrences in the input file, the first {\tt \$RUNTIME} 
+occurrences will be interpolated.
+
+For more details, see section \ref{subsec_interpolator}.
+
+\item Model grid data file writing
+
+The grid data files {\em grids.nc, masks.nc} and {\em areas.nc} can
+now be written directly at run time by the component models, if they
+call the new routines prism\_start\_grids\_writing, prism\_write\_grid,
+prism\_write\_corner prism\_write\_mask, prism\_write\_area,
+prism\_terminate\_grids\_writing. 
+
+The writing of those grid files by the models is driven by the
+coupler. It first checks whether the binary file {\em grids} or the
+netCDF file {\em grids.nc} exists (in that case, it is assumed that
+{\em areas} or {\em areas.nc} and {\em masks} or {\em masks.nc} files
+exist too) or if writing is needed. If {\em grids} or {\em grids.nc}
+exists, it must contain all grid information from all models; if it does not
+exist, each model must write its grid informations in the grid data
+files. 
+
+See section \ref{subsubsec_griddef} for more details.
+
+\item Output of CF compliant files
+
+The NetCDF output files written by the PSMILe for fields with status
+{\tt EXPOUT, IGNOUT} and {\tt OUTPUT} are now fully CF compliant.
+
+In the NetCDF file, the field attributes ``long\_name'' and ``units''
+are the ones corresponding to the field index in {\em
+cf\_name\_table.txt} (see above and section
+\ref{subsec_cfnametable}). The field index must be given by the user
+as the third entry on the field first line in the namcouple.
+
+Also, the latitudes and the longitudes of the fields are now
+automatically read from the grid auxiliary data file {\em grids.nc} and
+written to the output files. If the latitudes and the longitudes of
+the mesh corners are present in {\em grids.nc}, they are also written to the
+ouput files as associated ``bounds'' variable.  This works whether the
+{\em grids.nc} is given initially by the user or written at run time by the
+component models (see above). However, this does not work if the
+user gives the grid definition in a binary file {\em grids}.
+
+\item Removal of pre-compiling key ``key\_BSend''
+
+
+The pre\_compiling key ``key\_BSend'' has been removed.  The default has
+changed: by default, the buffered MPI\_BSend is used, unless {\tt NOBSEND}
+is specified in the namcouple after MPI1 or MPI2, in which case the
+standard blocking send MPI\_Send is used to send the coupling fields.
+
+\end{itemize}
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UGRefs.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UGRefs.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UGRefs.tex	(revision 1677)
@@ -0,0 +1,69 @@
+\newpage
+\begin{thebibliography}{10}
+
+\bibitem{SCRIPR}http://climate.lanl.gov/Software/SCRIP/index.htm
+
+\bibitem{mpp_io}http://www.gfdl.gov/\~~vb/mpp\_io.html
+
+\bibitem{udunits}http://www.unidata.ucar.edu/packages/udunits/udunits.dat
+
+\bibitem[Legutke and Gayler(2004)]{leg04} Legutke, S. and V.Gayler,
+  2004: The PRISM Standard Compilation Environment.
+  PRISM Report Series No 4. 
+
+\bibitem[Gayler and Legtke(2004)]{gay04} Gayler, V. and S. Legutke,
+  2004: The PRISM Standard Running Environment.
+  PRISM Report Series, No 5. 
+
+\bibitem{val04b} Valcke, S., 
+  2004: The PRISM TOYCLIM Coupled Model Adaptation Guide. 
+  PRISM Report Series, No 7, 70 pp.
+
+\bibitem{car04a} Carril, A., R. Budich, and S. Valcke,
+  2004: The TOYCLIM Demonstration Run Report.
+  PRISM Report Series No 13.
+
+\bibitem{cassou}
+C.~Cassou, P.~Noyret, E.~Sevault, O.~Thual, L.~Terray, D.~Beaucourt, and
+  M.~Imbard.
+\newblock Distributed Ocean-Atmosphere Modelling and Sensitivity to the
+  Coupling Flux Precision: the CATHODe Project.
+\newblock {\em Monthly Weather Review}, 126, No 4: 1035-1053, 1998.
+
+\bibitem{meteo}
+L.~Terray and O.~Thual.
+\newblock Oasis: le couplage oc\'ean-atmosph\`ere.
+\newblock {\em La M\'et\'eorologie}, 10:50--61, 1995.
+
+\bibitem{pontaud}
+M.~Pontaud, L.~Terray, E.~Guilyardi, E.~Sevault, D.~B. Stephenson, and
+  O.~Thual.
+\newblock Coupled ocean-atmosphere modelling - computing and scientific
+  aspects.
+\newblock In {\em 2nd UNAM-CRAY supercomputing conference, Numerical
+  simulations in the environmental and earth sciences}
+\newblock Mexico-city, Mexico, 1995.
+
+ \bibitem{clim}
+E.~Sevault, P.~Noyret, and L.~Terray.
+\newblock Clim 1.2 user guide and reference manual.
+\newblock {\em Technical Report TR/CGMC/95-47}, CERFACS, 1995.
+
+\bibitem{noyret}
+P.~Noyret, E.~Sevault, L.~Terray and O.~Thual.
+\newblock Ocean-atmosphere coupling. 
+\newblock {\em Proceedings of the Fall Cray User Group (CUG) meeting},
+1994.
+
+\bibitem{terray1}
+L.~Terray, and O.~Thual.
+\newblock Coupled ocean-atmosphere simulations. 
+\newblock In {\em High Performance Computing in the Geosciences,
+proceedings of the Les Houches Workshop}
+\newblock F.X. Le Dimet Ed., Kluwer Academic Publishers B.V, 1993.
+
+
+% http://www.cgd.ucar.edu/cms/eaton/cf-metadata/index.html
+
+
+\end{thebibliography}
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/UG_Acknowledgements.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/UG_Acknowledgements.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/UG_Acknowledgements.tex	(revision 1677)
@@ -0,0 +1,69 @@
+\newpage
+
+%\addcontentsline{toc}{section}{Acknowledgements}
+%\centerline{\bf Acknowledgements}
+
+\chapter{Acknowledgements}
+
+We would like to thank the main past or present developers of OASIS
+are (in alphabetical order, with the name of their institution at the time):
+\begin{description}
+  \item Arnaud Caubel (FECIT/Fujitsu)
+  \item Damien Declat (CERFACS)
+  \item Veronika Gayler (MPI-M\&D)
+  \item Jean Latour (Fujitsu-Fecit)
+  \item Eric Maisonnave (CERFACS)
+  \item Elodie Rapaport (CERFACS)
+  \item Hubert Ritzdorf (CCRLE-NEC)
+  \item Sami Saarinen (ECMWF)
+  \item Eric Sevault (M\'et\'eo-France)
+  \item Laurent Terray (CERFACS)
+  \item Olivier Thual (CERFACS)
+  \item Sophie Valcke (CERFACS)
+  \item Reiner Vogelsang (SGI Germany)
+\end{description}
+
+We also would like to thank the following people for their help
+and suggestions in the design of the OASIS software (in alphabetical
+order, with the name of their institution at the time):
+
+\begin{description}
+  \item Dominique Astruc (IMFT)
+  \item Sophie Belamari (M\'et\'eo-France)
+  \item Dominique Bielli (M\'et\'eo-France)
+  \item Gilles Bourhis (IDRIS)
+  \item Pascale Braconnot (IPSL/LSCE)
+  \item Christophe Cassou (CERFACS)
+  \item Yves Chartier (RPN)
+  \item Jalel Chergui (IDRIS)
+  \item Philippe Courtier (M\'et\'eo-France)
+  \item Philippe Dandin (M\'et\'eo-France)
+  \item Michel D\'equ\'e (M\'et\'eo-France)
+  \item Ralph Doescher (SMHI)
+  \item Jean-Louis Dufresne (LMD)
+  \item Jean-Marie Epitalon (CERFACS)
+  \item Laurent Fairhead (LMD)
+  \item Marie-Alice Foujols (IPSL)
+  \item Gilles Garric (CERFACS)
+  \item Eric Guilyardi (CERFACS)
+  \item Charles Henriet (CRAY France)
+  \item Pierre Herchuelz (ACCRI)
+  \item Maurice Imbard (M\'et\'eo-France)
+  \item Luis Kornblueh (MPI-M)
+  \item Stephanie Legutke (MPI-M\&D)
+  \item Claire L\'evy (LODYC)
+  \item Olivier Marti (IPSL/LSCE)
+  \item Claude Mercier (IDRIS)
+  \item Pascale Noyret (EDF)
+  \item Andrea Piacentini (CERFACS)
+  \item Marc Pontaud (M\'et\'eo-France)
+  \item Ren\'e Redler (NEC-CCRLE)
+  \item Tim Stockdale (ECMWF)
+  \item Rowan Sutton (UGAMP)
+  \item V\'eronique Taverne (CERFACS)
+  \item Jean-Christophe Thil (UKMO)
+  \item Nils Wedi (ECMWF)
+\end{description}
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/anaisga.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/anaisga.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/anaisga.tex	(revision 1677)
@@ -0,0 +1,865 @@
+ \magnification =\magstep1
+\count0=77
+%definitions
+
+%end of definitions
+
+
+\centerline{ Olivier Thual, March 15$^{\rm th}$ 1992}
+\centerline{ Revised version  June 30$^{\rm th}$ 1992}
+ \bigskip
+
+\centerline{\bf SIMPLE OCEAN-ATMOSPHERE INTERPOLATION.}  
+\centerline{\bf PART A: THE METHOD}
+
+\bigskip
+ epi920629-naiva-ot6.tex
+A simple and naive method to interpolate fields between an atmospheric
+and an oceanic grid is presented. This crude method is coded into a set of
+FORTRAN programs, in the expectation  of a more elaborated method which
+takes into account the particular physic of the ocean-atmosphere coupling. 
+
+
+
+\beginsection 1. INTRODUCTION 
+
+The coupling of an atmosphere General Circulation Model (GCM) and an 
+oceanic GCM involves both a temporal coupling,  which  deals  with
+the synchronization and the communication between  the two codes at
+suitable time steps, and a spatial coupling which  deals with the
+interpolations of suitable fields from one GCM grid to another, namely the
+fluxes from the atmospheric to the ocean grid, and the sea surface
+temperature (SST) in the reverse direction.  
+
+
+
+These two aspects of the coupling are presently attacked in parallel in the
+CERFACS Climate Modelling \& Global Change team.  They have started
+with a gathering of all the state of art informations that we have been
+able to record in the Climatic community and that have been summarized
+in [1]. Today, progress has been made  in the two directions.
+
+ In [2], a method based on the communication and synchronization of  UNIX
+processes is developed for the GCMs temporal coupling task. The skeleton
+of a universal ``coupler'' has been written in FORTRAN.
+This software 
+controls all  the exchanges between an oceanic and an atmospheric codes.
+Its present conception allows a simple
+implementation in an already written and tested GCM, with   minimum
+coding changes in it.
+
+
+
+This coupler skeleton includes a black box which will  perform the spatial
+interpolations between the atmospheric and  oceanic grids. Different 
+interpolation schemes can be plugged in this black box, which further
+increases the universality of the coupler.  The fundamental basis for the
+design of an advanced interpolation scheme is presented in [3]. In this
+scheme a particular focus is made on the ``local conservation'' of the
+fluxes when the interpolation from the atmospheric to the oceanic grid is
+performed. It is thought ([3]) than the non-conservation of the fluxes
+might be one of the causes of  the drift problem encountered when two  GCMs,
+individually well tuned, are coupled together. 
+
+
+
+In the expectation of the achievement and coding of this advanced
+interpolation scheme, it has appeared necessary to plug into the coupler
+spatial interpolation black box a simple and quickly written package of
+FORTRAN subroutines  in order to start real size tests of the coupler with
+ GCMs.  The purpose of this letter is to expose the
+``naive'' and crude interpolation method that we have chosen in this spirit.
+It is based on the informations that we have collected in our inquiry on the
+state of the art spread among the climatic community (see [4]) and
+summarized in [1]. 
+
+A basic introduction to the interpolation of data grid points is presented
+in Section 1, and the specific problem of the grid-to-grid interpolation is
+discussed in Section 2. These two sections are finalized by the description
+of the ``naive interpolation method'' that will be plugged into the coupler
+black box. This method have been coded in FORTRAN and is now under a
+testing stage.  The results of the tests will be exposed in Part B of this
+letter. In Section 3, some steps towards the design of a less naive
+grid-to-grid interpolation method are indicated, and could be easily
+implemented in the ``naive method'' FORTRAN software, if they are
+retained as pertinent developments worth the effort.
+
+
+A lot of materials exposed here, at a pedagogical and
+simple level, are presented in a more complete and detailled manner in [3].
+This is the case, for instance, for  the gaussian basis and overlapping of
+Sections 2 and 3, and of the Lagrangian formalism. For furthers details, and
+in particular numerical tests of various interpolation methods in the 1D
+case, the reader is referred to [3].
+
+
+
+
+ 
+
+\beginsection  2.  BASIC FACTS ABOUT INTERPOLATION 
+
+Interpolation is a problem that often occurs in physics, and we all have
+had some experience in it, in a way or another.  Due to the numerous
+approachs that can be found in the literature, I  have chosen to build a
+pedagogical presentation from scratch, restricted to the materials
+necessary to expose the ``naive method''  that I have coded.  Simple
+notations for the indexing of masked grids are given, in order to be used
+in  this presentation. The family  of the linear  interpolations associated to a 
+grid is presented in a formalism focusing  their  functions basis set.
+Several illustrative examples are presented, ending with exposition of the
+``$L$-neighbor naive method''.
+
+
+
+\beginsection 2.1 Grids and masks
+
+Let $r_{lm}= (x _{lm}, y _{lm})$, $ \; l=1,N_1$, $ \; m=1,N_2$ the
+coordinates of a rectangular 2D grid.  In order to define the sea and the
+land, let $M _{lm}$ a $N_1 \times N_2$ matrix called ``mask'' such that,
+for instance,  $M _{lm}=1$ means that  $r_{lm}$ is a ``sea'' grid and  $M
+_{lm}=0$ means that  $r_{lm}$ is a ``land'' grid. In all the present
+discussion, we will only consider the sea points of the grid and discard the
+land points.  If  $N$ is the number of sea grid points  we will denote them
+by $r_i=(x_i, y_i),\; i=1,N$ and no mask  needs to  be mentioned anymore in
+the presentation  of the sea grid. The notion of mask is still useful
+however in the numerical implementation of  algorithms dealing  with
+thoses grids. Another advantage  is the convenient generalization of the
+notations to 1D or 3D grids. 
+
+
+
+
+
+\beginsection 2.2 The linear interpolation family of a grid
+
+The most common meaning of the word interpolation when dealing with a
+grid $(r_i),\;  i=1,N$ with a real  value $(a_i),\; i=1,N$
+ at each point is the
+determination of a function $f(r)$ on the whole space (1D, 2D or 3D
+depending on the case), which allows to extrapolate the values $a_i$'s in
+any point $r$ located on or outside the grid.  
+Note that an interpolation does not necessarily requires $f(r_i)=a_i$. 
+
+
+
+ Any  linear interpolation method can be expressed as
+$$
+f(r)= \sum_{i=1}^{N} a_i \varphi_i(r)
+\eqno(2.1)
+$$
+where the $ \varphi_i(r)$'s are  functions localized around $r_i$ such that,
+for all $r$: 
+$$
+ \sum_{i=1}^{N}\varphi_i(r) dr = 1
+\eqno(2.2)
+$$
+for all $i$. 
+Let us call call these functions ``the basis'' of the interpolation.
+ 
+
+
+For a given grid, the family of all the possible interpolations of the form
+(2.1) is as big as all the possible  choices of the basis functions. 
+The choice of a particular interpolation depends on physical
+considerations, which  depend on  the use that one intends to make 
+of the function $f(r)$. 
+
+
+
+\medskip
+
+Let us  assume that the 
+ general shape of the $ \varphi_i(r)$'s is more or less the same on all
+the grid. This is the case,  for instance, when 
+ a given  $ \varphi_i(r)$ ``covers''
+ roughly the same number of
+neighbors for most of the points of the grid. 
+It  is then  possible to define the ``overlap order'' of an interpolation 
+by looking at 
+how much  the support of the $ \varphi_i(r)$'s overlap, taking into account
+how fast   the absolute  value of $ \varphi_i(r)$.
+
+ There is no need here to
+give a more precise definition that this intuitive concept of ``overlap
+order''. 
+
+\vfill\eject
+
+
+\beginsection 2.3  The ``closest neighbor'' interpolation 
+
+Given a distance in the space where stands the grid, for instance 
+ on  a plane or on a
+sphere),  the ``closest neighbor'' interpolation is such that
+ $f(r)=a_{i(r)}$, where
+  $a_{i(r)}$  is the  value data at the closest neighbor 
+ $r_{i(r)}$, i.e. the grid point which minimizes the
+distances $(|r-r_i|), \; i=1,N$.  
+
+
+
+This  interpolation can be expressed under the form (2.1) with
+$\varphi_i(r)$ being 1 on the open domain $S_i$ of all the points
+$r$ which admit $r_i$ as their closest neighbor and  $|S_i|$  its area.  It
+is  1/2 on the boundary  of this domain for the  points at equal distance
+from 2 grid points, 
+1/4 at the ``corners'' at equal distance of 4 grid points, and so on.
+  It is zero outside of the domain $S_i$. 
+
+
+
+The overlap order of this interpolation is zero, because the support domains
+$S_i$ of the basis functions do not intersect.  The function $f(r)$  of this
+interpolation is discontinuous. 
+
+\vfill\eject
+
+\beginsection 2.4 Familiar Interpolations
+
+The linear interpolation is simple to understand on a 1D grid. Given $N$
+values  $(a_i) i=1,N$ at the  real  points $(x_i),\; i=1,N$ the linear
+interpolation reads:
+$$
+f(x)=(a_{i+1}-a_i) { x-x_i \over x_{i+1} - x_i }  + a_i
+\qquad \hbox{if} \quad x\in [x_i, x_{i+1}] \;,
+\eqno(2.3)
+$$
+i.e.  a piece linear function such that $f(x_i)=a_i$ for all points.
+
+
+
+Simple algebraic manipulations show that  this interpolation  can be put
+under the form (2.1) with 
+$$
+\varphi_i(x)=\left\{\matrix{ 
+{x-x_{i-1}\over  x_{i}-x_{i-1} }
+\qquad \hbox{if} \quad x\in [x_{i-1}, x_{i}]  \cr
+{x-x_{i+1}\over  x_{i}-x_{i+1} }
+\qquad \hbox{if} \quad x\in [x_{i}, x_{i+1}]  \cr
+0
+\qquad \hbox{elsewhere}}  \right.
+\eqno(2.4)
+$$
+This function is equal to one at $x_i$, zero at the point $x_{i-1}$ and
+$x_{i+1}$ and outside $ [x_{i-1}, x_{i+1}]$, and is piecewise linear on two
+intervals. 
+ 
+
+
+
+\bigskip
+
+The linear interpolation on a 2D grid $r_{lm}=(x_{lm},y_{lm})$ can also be
+put under the form
+$$
+f(r)= \sum_{l,m} a_{lm} \varphi_{lm}(r)
+\eqno(2.5)\;,
+$$
+with $\varphi_{lm}(r)$ equal to one at $r_{lm}$, zero at  the four points
+$r_{l-1,m-1}$,  $r_{l+1,m-1}$,  $r_{l+1,m+1}$,  $r_{l-1,m+1}$ and outside
+the  polygon that they form, and piecewise linear on four triangles that
+they make with $r_{lm}$.
+
+
+
+\bigskip
+
+It can be said that the overlap order of the linear interpolation is one,
+as two basis functions can overlap on one grid mesh.  It is intuitive to say
+that the higher the overlap, the smoother the interpolation.  
+I will not try  to consider  here interpolations like quadratic interpolations 
+or splines, which certainly enter into the form (2.1). 
+
+  
+
+\beginsection 2.5 ``Unique weight function'' interpolation 
+
+Instead I will study a very natural interpolation base on the choice  of a
+``weight function''  $\phi(u)$, which can be, as an example, a gaussian:
+$$
+\phi(u)= e^{-{u^2 \over 2\sigma^2}} \;.
+\eqno(2.6)
+$$
+The normalization constant in front of the  exponential can be anything as 
+will be seen below.  
+
+
+
+With the choice of a ``weight function''  one  can define the  interpolation 
+$$
+f(r)= {1\over Z(r)} \sum_{i=1}^{N} a_i\;  \phi(r-r_i)\;,
+\eqno(2.7)
+$$
+where 
+$$
+Z (r)=  \sum_{i=1}^{N}  \phi(r-r_i)\;,
+\eqno(2.8)
+$$
+to ensure (2.2).
+This function $Z(r)$ depends on the geometry of the grid and on the weight
+function $\phi$, and its graphic visualization might give some valuable
+information about the  chosen method.  The same remark holds for the
+individual $ \varphi_i(r) =  \phi(r-r_i) /Z(r)$.
+
+
+\vfill\eject
+
+
+\beginsection 2.6 The ``$L$ neighbors naive interpolation''
+
+The numerical  implementation of the above ``unique weight''  interpolation
+is simple to code, but it costs of order $N$ operation for each   point $r$
+where the value of $f(r)$ is  calculated.  In order to save computing time
+this interpolation can be approximated  or mimiced by what I call the
+``naive method of order $L$'':
+$$
+f(r)={1\over Z(r)}   \sum_{m\in I(r)}  a_i \; \phi(r-r_m)
+\eqno(2.9)
+$$
+where $I(r)=\{ i_1(r), i_2(r), ..., i_L(r) \}  $ is the set containing the 
+indices of the  $L$ closest neighbors of $r$. The function $Z(r)$ ensures,
+as usual, that the sum of the weights is one, and is here:
+ $$
+Z(r)=  \sum_{m\in I(r)}   \phi(r-r_m)
+\eqno(2.10)
+$$
+This function should also be worth graphic plots for various choices of the  
+integer $L$ and the  variance of $\phi$ ($\sigma$ for the gaussian).
+
+
+
+\medskip
+
+This  ``naive interpolation'' can also be expressed  under the form (2.1),
+with 
+$$
+\varphi_i(r) =\left\{\matrix{   \phi(r-r_m)/Z(r) \qquad \hbox{if} \quad
+r \in  S^L_j  \cr
+0  \qquad \qquad \hbox{elsewhere}} \right.   
+\eqno(2.11)
+$$
+where $S_j^L$   is the   domain of all the points $r$ which admit the grid
+point $r_j$ in the list  of the $L$ closest neighbors.  The values at the
+boundary has to be adjusted as for the ``closest neighbor'' interpolation,
+which   is the particular case $L=1$ and $\phi=1$.
+
+
+
+
+
+
+
+\beginsection 3. GRID-TO-GRID INTERPOLATION
+
+There is a big difference between the interpolation from a set of data on a
+grid to a function $f(r)$ defined everywhere, and a grid-to-grid
+interpolation. In a grid-to-grid interpolation, a set of data is given on a
+first grid, the ``source grid'', and the interpolation must generate from
+these a set of data on a new grid, the ``target grid''. This  problems occurs
+in the ocean-atmosphere coupling problem where fluxes must be transmitted
+from the atmospheric grid to the oceanic grid, and sea surface temperature
+(SST) 
+from the oceanic grid to  the atmospheric grid. 
+ Of course, given an interpolation  on the source grid, one can apply the
+interpolated function $f(r)$ at each point of the target grid to define a
+grid-to-grid interpolation. But this choice can be extended through a
+Lagrangian formalism where the grid-to-grid interpolation depends on an
+interpolation on the source grid and also an interpolation of the target
+grid. Indeed the grid-to-grid interpolation depends on what the physicist
+intends to do with the interpolated values, and this can generally be
+expressed through the definition of an interpolation on the target grid. 
+These considerations will guide the choices of the parameters of our ``naive''
+grid-to-grid interpolation (number of neighbors and variance).  
+
+\vfill\eject
+
+
+\beginsection 3.1 Sea domains and Ocean-Atmosphere coupling
+
+The grid of an Atmospheric General Circulation Model (AGCM)  is made  of
+``land points'' and ``sea points''. The grid of an Oceanic General Circulation
+Model (OGCM)  is, by definition, only made of ``oceanic points''.  The AGCM
+``sea points''  and the OGCM ``oceanic points''  generally do not coincide,
+except  when the same grids  has been chosen. 
+
+
+
+The fluxes of the AGCM are known at all  the points, land or sea, and one of
+ the 
+task of the coupler is to interpolate them for  the OGCM grid. 
+This can be done
+either by using all the  grid,  with no distinction between land and sea
+points, or only taking into account the sea points. This last point is still
+under debate.  There is no such a choice
+however when passing the sea surface temperature (SST) of the OGCM  grid
+to the AGCM ``sea points''.
+
+
+
+In all these cases, it is possible to denote by  by $(r^a_i),\; i=1,N^a$ the
+``source grid'' on which are known the data and $(r^b_i),\; i=1,N^b$ the
+``target grid'' on which the interpolated values must be calculated.  The
+two domains of the two grids are likely to  have  a large intersection and
+sometimes a not so small differences (the complementary of  the
+intersection in the reunion of the the two domains).  The influence of the 
+difference set of the two grids in a grid-to-grid interpolation  will be
+investigated in Part B of this letter,  through numerical tests. 
+
+
+
+\beginsection 3.2  Lagrangian formalism
+
+A grid-to-grid interpolation always assumes, even  if  not said, the
+choice of an interpolation  on the  source  grid as well as on the target
+grid.  
+
+
+
+Let 
+$$
+f(r)=\sum_{i=1}^{N^a} a_i \varphi_i(r) 
+\eqno(3.1)
+$$
+a chosen interpolation on the source grid A defined by the points $(r^a_i),\;
+i=1,N^a$,  at which the values $a_i$ are known. 
+
+
+
+Let 
+$$
+g(r)=\sum_{j=1}^{N^b} b_i \psi_j(r) 
+\eqno(3.2)
+$$
+a chosen interpolation on the target grid B defined by the points $(r^b_i),\;
+j=1,N^b$,  at which the values $b_i$ are unknown an to be calculated
+through a grid-to-grid interpolation.  
+
+
+
+Such a grid-to-grid interpolation can be defined by the minimization of
+the Lagrangian:
+$$
+L(b_1, b_2, ..., b_{N^b}) =  \int [f(r)-g(r)]^2  dr \;.
+\eqno(3.3)
+$$
+The integral is on all the domain, owing the fact that the $
+\varphi_i(r)$'s can be zero outside their support. 
+It is natural to minimize this Lagrangian  in order to  have $f(r)$ as close
+as possible of $g(r)$. 
+The set of coefficients $(b_j),\; j=1,N^b$ which  realizes this minimization
+is found by saying that all the partial derivatives $\partial L / \partial
+b_j$ vanish. Some straightforward algebraic manipulations show that this
+lead the  $N^b$ linear equations:
+$$
+2 \sum_{j=1}^{N^b}  < \psi_m | \psi_j > b_j 
+=2 \sum_{i=1}^{N^a}  < \psi_m | \varphi_i> a_i 
+\qquad \hbox{for} \quad m=1,N^b
+\eqno(3.4)
+$$
+where 
+$$
+  < \psi_m  |\psi_j > = \int    \psi_m (r)\psi_j(r) dr  =:  V_{mj}
+\eqno(3.5) 
+$$
+and 
+$$
+  < \psi_m |  \varphi_i > = \int    \psi_m (r)\varphi_i(r) P(r) dr  =:  U_{mi}
+\;.
+\eqno(3.6) 
+$$
+
+
+
+In order to find the $N^b$ values $b_j$'s, one has to invert the linear
+system $VB =  UA$:
+$$
+\sum_{j=1}^{N_b} V_{ml}\;  b_j =   \sum_{i=1}^{N_a}  U_{mi}\;  a_i
+\qquad\hbox{for}\quad m=1,N^b
+\eqno(3.7)
+$$
+
+
+
+The inversion of the $N_b$ x $N_b$  matrix $V$ is  possible if  the
+$\psi_j$'s are a good basis, and the grid-to-grid interpolation finally
+reads: $B=V^{-1}U    A$. 
+
+
+
+
+
+\beginsection 3.3 The choice of the two grid interpolations
+
+
+
+Choosing the ``closest neighbor'' interpolation for the target grid, in the
+above formalism,  lead to a very easy implementation of the method because
+the matrix $V$ is equal to  unity.  The interpolation chosen on the source
+grid (grid A) is  then the  only one  which determines the grid-to-grid
+interpolation and reads:
+$$
+b_j= \sum _{i=1}^{N^a}  a_i  \overline{\varphi_i}^{S_j}(r_j^b)
+\eqno(3.8)
+$$
+where
+$$
+\overline{\varphi_i}^{S_j}(r_j^b)=  \int_{S_j} \varphi_i(r)
+\eqno(3.9)
+$$
+is the  average of   $\varphi$ on the  ``closest neighbor'' cell surrounding
+$r_j$.  When the variance of $\varphi_i$ is large compared to the size of
+this  domain,  this average is close to its value at $r_j$ and we have 
+approximatively $b_j\sim f(r_j)$.  On the contrary, if  this variance is 
+small compared  to the size of the ``closest neighbor''  cells of the  target
+grid (grid B),  the grid-to-grid interpolation is approximatively the trivial
+interpolation for which all the $b_j$'s are equal to the mean value 
+$\sum_i a_i$.
+
+
+
+
+\bigskip
+
+
+Having this in  mind, I want to express here some  intuitive  ideas  about
+the choice of the source and target grid interpolation, when building a
+grid-to-grid interpolation with the above Lagrangian formalism. Let us
+consider three situations.
+
+\medskip
+
+
+
+\item{*} {\bf  Coarse to thin grid}. If the source grid A is coarser that the 
+target grid B, it seems natural  to choose the ``closest neighbor''
+interpolation on grid B. On grid A, one feels that  an smooth interpolation 
+with an ``overlap order'' which is be 2 or 5 times
+ to the thinest ratio of the
+two grids, i.e., the ratio of the average mesh size  of the coarse grid A over
+the average mesh size  of the thin grid B. 
+
+\medskip
+
+ \item{*} {\bf Thin to coarse grid}. It the source grid A is thiner that the 
+target grid B. One can still try to choose the ``closest neighbor''
+interpolation on grid B. 
+On grid A, one feels that  an smooth interpolation  with an ``overlap order''
+which is roughly equal to the coarsest ration of the two grid, i.e., the ratio
+of the average mesh size  of the thin grid A over the average mesh size  of
+the coarse grid B. 
+
+
+
+
+
+\beginsection 3.4 The grid-to-grid  ``naive'' method
+
+All the above considerations have been addressed in order to explain the 
+grid-to-grid  ``naive'' method that is  being build as a temporary  modulus, 
+waiting for a  less naive  method  to be coded. 
+
+
+
+In this naive method the fluxes $b_j$ on the ocean grid B $(r^b_j),\;  j=1,N^b$ 
+are  obtained  from the fluxes $a_i$ of the atmospheric grid A $(r^a_i),\;
+i=1,N^a$  simply by applying the $L^a$ neighbors $\sigma_a$-gaussian
+interpolation with :
+ $$
+b_j={1\over Z^a(r^b_j)}   \sum_{m\in I(r^b_j)}  a_i  e^{-{(r^b_j-r^a_m)^2
+\over 2 \sigma_a^2} }
+\eqno(3.10)
+$$
+where $I(r^b_j)=\{ i_1(r^b_j), i_2(r^b_j), ..., i_{L^a}(r^b_j) \}  $ is the set
+containing the  indices of $L^a$ closest neighbors A-grid points $r^a_m$
+of the B-grid point $r^b_j$, and   
+$$
+Z^a(r^b_j) =  \sum_{m\in I(r^b_j)}   e^{-{(r^b_j-r^a_m)^2 \over 2
+\sigma_a^2} }\;.
+\eqno(3.11)
+$$
+
+
+
+\medskip
+
+When interpolating the SST (sea surface  temperature) for the oceanic grid 
+B to the atmospheric grid, the same principle is applied with 
+the $L^b$ neighbors $\sigma_b$-gaussian interpolation:
+ $$
+a_i={1\over Z^b(r^a_i)}   \sum_{m\in J(r^a_i)}  b_i  e^{-{(r^a_i-r^b_m)^2
+\over 2 \sigma_b^2} }
+\eqno(3.12)
+$$
+where $J(r^a_i)=\{ j_1(r^a_i), j_2(r^a_i), ..., i_{L^b}(r^a_i) \}  $ is the set
+containing the  indices of $L^b$ closest neighbors B-grid points $r^b_m$
+of the A-grid point $r^a_i$, and
+$$   
+Z^b(r^a_i) =  \sum_{m\in J(r^a_i)}   e^{-{(r^a_i-r^b_m)^2 \over 2
+\sigma_b^2} }
+\eqno(3.13)
+$$
+
+\vfill\eject
+
+
+\bigskip 
+
+The adjustable parameters of this ``naive method'' are the two integers
+$L^a$ and $L^b$ and the two variances $\sigma_a$ and $\sigma_b$.  For a
+given couple of grids A and B, their choice can be guided by the above 
+analysis base on the Lagrangian formalism. 
+
+
+
+If Grid B is thiner than Grid A, which is the case for the
+Ocean-Atmosphere coupling, it is reasonable to choose $L^a$ or order 10
+and $\sigma_a$ of the order of the average mesh of grid A. In the  above
+formalism of the Lagrangian interpolation, this choice corresponds to 
+the $L^a$ neighbors $\sigma_a$-gaussian interpolation on Grid A,  i.e.,
+and the ``delta-comb'' interpolation on Grid B, i.e., the choice of delta
+function for the $\psi_j$'s.  The inverse Grid B to Grid A interpolation can
+be expressed the same way, but with a different choice of $L^b$. Indeed, it
+seems natural to choose $L^b$ such that $L^b/L^a$ is of the order of the
+ratio between the A-grid and B-grid average mesh size, and $\sigma_b$ of
+the order of $\sigma_a$. With this choice a composition between a A to B
+and B to A grid interpolation is close to the Identity, which is a reasonable
+criteria to impose when no other information is assumed on the nature of
+the fields to be interpolated. 
+
+
+
+
+
+
+
+\beginsection 4. TOWARD A LESS NAIVE METHOD
+
+For the case of Ocean-Atmosphere coupling, information is known about
+the structure of the flux or SST fields to interpolated, and about the
+geometry of the   grid. The naive method should be thus replaced by
+grid-to-grid interpolations adapted to the specific physical problem of the
+Ocean-Atmosphere coupling. These interpolation have to be  tuned in order
+to answer specific quality criteria, imposed by physical arguments.  This
+tuning can be achieved through the choice of the basis functions  the
+source grid interpolation (the Atmospheric grid when passing fluxes, and
+the Oceanic one when passing the SST).  Constraints like the conservation
+of the global integral of fluxes can be satisfied by adding Lagrange
+multipliers in the Lagrangian  formalism. At last, a choice of the target
+grid  interpolation, different from the ``Dirac comb'' interpolation can be
+necessary. In this last case the inversion of the matrix $V$ of Equation
+(3.6) has to be done once for all, and the multiplication by $V^{-1}$, which
+is generally not sparse, has to  be performed for each new field to be
+interpolated.  The numerical computation of the elements of $U$ by
+Monte-Carlo techniques is briefly discussed.  
+
+
+
+\beginsection 4.2 Inhomogeneous and anisotropic interpolation
+
+The choice of the interpolation basis $\varphi^a_i(r)$ and $\varphi^b_j(r)$
+of the grid A and B considered as source grids (i.e. when interpolating
+fluxes or SST respectively), can be tuned in function of the geometry of
+the two grids, and the knowledge of the  physical structure of the fields to
+interpolate. For instance, some anisotropy could be given to these
+functions if the fields have a higher correlation in a particular direction
+(e.g. in latitudinal direction  on  the sphere).  Near the edges of the two
+grids, i.e. the costs, a special choice of the basis function, adapted to the
+geometry or the physical processes should be performed.  
+
+
+
+\beginsection 4.3 Lagrangian formalism with constraints
+
+When passing the flux of a quantity, like heat for instance, from the
+atmospheric grid to the oceanic grid it might be important to ensure that
+the amount of  the heat lost by the AGCM is  equal to the heat received by
+the OGCM.  This conservation can be implemented by imposed one  or
+several constraints in the definition of the interpolation. 
+
+
+
+Taking the notation of the Langragian formalism of Section 3, the
+constraints 
+$$
+\int f(r) dr = \int g(r) dr
+\eqno(4.1)
+$$
+defines a new grid-to-grid  interpolation  obtained by minimizing
+$$
+L(b_1, b_2, ..., b_{N^b})
+ =  \int [f(r)-g(r)]^2  dr + \lambda \int [f(r)-g(r)]  dr
+\eqno(4.2)
+$$
+where $\lambda$ is a Lagrangian multiplier. 
+
+
+
+With this constraint, Equation (3.4) is now replaced by the system
+$$
+\left\{
+\eqalign{ 
+ 2 \sum_{j=1}^{N^b}  < \psi_m | \psi_j > b_j 
+=&2 \sum_{i=1}^{N^a}  < \psi_m | \varphi_i> a_i - \lambda < \psi_m | 1 > 
+ \qquad \hbox{ for all } \quad m=1,N^b \cr
+ \sum_{j=1}^{N^b}
+  < \psi_j | 1 > b_j  =&  \sum_{i=1}^{N^a}  < \varphi_i | 1 >
+a_i
+} \right. 
+\eqno(4.3)
+$$
+where 
+$$
+< \psi_j | 1 > = \int \psi_j dr = : H_j
+\eqno(4.4) 
+$$
+and 
+$$
+< \varphi_i | 1 > = \int \varphi_i dr = : G_j
+\eqno(4.4) 
+$$
+
+Equation (3.7) is now replaced by a system $VB=UA-\lambda H$ with $HB=
+GA$:
+$$
+\left\{
+\eqalign{
+\sum_{j=1}^{N_b} V_{ml}\;  b_j =&   \sum_{i=1}^{N_a}  U_{mi} \; a_i - \lambda 
+G_m
+\qquad\hbox{for}\quad m=1,N^b  \cr
+\sum_{j=1}^{N^b}  H_j \; b_j  =&  \sum_{i=1}^{N^a}  G_i\; a_i 
+}\right.
+\eqno(4.5)
+$$
+
+
+
+This system is solved by first inverting the matrix $V$, which leads to the
+system $B=V^{-1}UA-\lambda V^{-1}H$ with $HB= GA$, and by
+eliminating $\lambda$. Let us denote $B^*= V^{-1}UA$, which is  the value
+of the coefficients that would be obtained without the constraint, and plug
+$B=B^*- \lambda V^{-1}H$ in the second equation. This gives the value of
+the Lagrange multiplier 
+$$
+\lambda= { H B^* - G A \over G V^{-1}H} \;
+\eqno(4.6)
+$$
+which gives a measure of how strongly the constraint is violated by the first
+guess $B^*$. This violation error is redistributed in the solution of the
+problem:
+$$
+\eqalign{
+B=& B^* - {H B^* - G A \over H V^{-1}H} V^{-1}H  \cr
+=& V^{-1}UA - {H V^{-1}UA - G A \over H V^{-1}H} V^{-1} H   \;.}
+\eqno(4.7)
+$$
+
+
+
+
+
+\beginsection 4.3 Practical considerations
+
+For the practical implementation of the interpolation methods which are
+derived from a Lagrangian formalism, one needs to know the numerical
+values of the quantities $V_{mj}=~~~<\psi_m | \psi_j> $,  $U_{mi}=  <\psi_m |
+\phi_i> $,   $H_m= <\psi_m | 1> $ and $G_i= <\varphi_i | 1> $. Even for the
+next neighbor interpolation basis, the numerical evaluation of these
+numbers is not straightforward. The complexity of this problem, however,
+do not exceed the one of the determination of the double integral  of an
+arbitrary function, which is an often encountered problem in physics. 
+Various methods can be found depending of the particular situation. 
+
+
+One of them is the evaluation of these integrals through Monte-Carlo
+techniques. For instance, if the functions $\psi_m$'s are the next neighbor 
+interpolation basis, the $H_m$'s are the surfaces of the non-intersecting
+domains $S_m$'s (see Section 2.3). If the surfaces of the grid meshes are
+known,  and if the grid is not too distorted (in a sense to be defined later), 
+it is possible to reduce the number of random shootings. Inside each  grid
+mesh formed by the four grid points $r_1$, $r_2$, $r_3$ and $r_4$, one
+can choose at random, with  a uniform probability, a big number of points. 
+For each of these  points $r$, it is only necessary to calculate the four
+values $\psi_1(r)$, $\psi_2(r)$, $\psi_3(r)$ and $\psi_4(r)$, associated to
+the four grid points at the corners of the mesh,   provided that  the grid is
+not too much distorted (by definition).  If so, the random point has to be
+chosen uniformly on a surface larger than the considered mesh. The same
+algorithm can be apply for the calculation the the $U_{mi}$'s. If the
+$\varphi_i$'s are the basis function of the $L$-closest neighbors
+interpolation,  this algorithm can be generalized.
+
+\vfill\eject 
+
+\beginsection 5. CONCLUSION
+
+The goal of this letter was to expose the ``naive'' grid-to-grid 
+interpolation  method that I have coded for the interpolation black box of
+the coupler.  For each point of the target grid, the algorithm search for its
+$L$-closest neighbor and calculates weight coefficients through the
+evaluation of a 
+gaussian function. This has to be done once for all, given a couple of grid,
+the addressed and the weight coefficients being the only information to be
+stored.  If $L$ is not big, this storage is not huge, and  the number of
+operation is also reasonable.  Test of this methods with several type of 
+grids will be presented in Part B. 
+
+In fact, the rough exposition  of the method could have been done quite
+more shortly if this  had been the only  considered goal.  But  the different
+formalisms presented in this letter are candidate to provide a framework
+to the intuitive ideas that one often   generates when dealing with this
+interpolation problem.  It can also be useful to try to translate into these
+formalisms more complicated interpolation methods, and, if not possible, 
+to see which  of their features do not enter in this framework. 
+
+
+
+\bigskip
+
+\noindent {\bf Acknowledgments:}  I thank all the participants of the ``Adm
+\& Science Team Meeting'' of March 11th, for their  remarks which have
+useful for the drafting of  this letter. 
+
+
+
+\beginsection REFERENCES
+
+\def\ref{\parskip 12pt \leftskip 20pt \parindent -20pt} 
+\def\endref{\parskip 0pt \leftskip 0pt \parindent 20pt}
+
+
+
+\ref
+[1]
+O. THUAL, Gathering information for a coupler,
+ {\it Epicoa \ } {\bf 1009} (1991).
+
+
+
+[2]
+ L. TERRAY, A simple communication scheme between coupler and GCM's, 
+ {\it Epicoa \ } {\bf 0203}  (1992). 
+
+
+
+[3]
+N. H. BARTH,  A Conservative Scheme for Passing Variables Between
+Coupled Models of the Ocean an Atmosphere,
+ {\it Technical Report\ }, CERFACS (1992).
+
+
+
+[4] ``Appel d'id\'ees pour la cr\'eation du coupleur du mod\`ele
+ communautaire'', written by  L. Terray,  October 10th 1991. 
+
+
+
+\endref
+
+
+
+\end
+
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/anaisgb.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/anaisgb.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/anaisgb.tex	(revision 1677)
@@ -0,0 +1,775 @@
+ \magnification =\magstep1
+\count0=90
+%definitions
+
+%end of definitions
+
+
+\centerline{ Olivier Thual, June 30$^{\rm th}$ 1992}
+ \bigskip
+
+\centerline{\bf SIMPLE OCEAN-ATMOSPHERE INTERPOLATION.}  
+\centerline{\bf PART B: SOFTWARE IMPLEMENATION}
+
+
+\bigskip
+
+
+A set of FORTRAN subroutines constitutes an implementation the ``naive''
+grid-to-grid interpolation method which has been exposed in the previous
+Part A of this letter. This implementation  is tested  for  both idealized, 
+EMERAUDE or OPA  grids, masks and scalar fields.  These
+subroutines can  be used in the first version the ocean-atmosphere coupler. 
+
+
+
+
+
+\beginsection 1. INTRODUCTION 
+
+Coupling two atmospheric and  oceanic general circulation models (AGCM
+and OGCM) having two different grids and sea-land masks, requires the
+interpolation of fluxes from the atmosphere to the ocean grids and of the
+sea surface temperature (SST) in the reverse direction.  A simple method
+to perform these interpolations have been presented in the previous Epicoa
+Letter [1]  called ``Simple ocean-atmosphere interpolation. Part A: the method'' as a
+particular case of a more general class of interpolations based on
+optimization theory (Lagrangian formalism).   
+
+\medskip
+
+The name  of ``naive method'' which has been given to denote one of the simplest
+interpolation among this class,  comes from the motivations
+which have governed its implementation. It was designed with simplicity
+requirement and short deadlines in order to reach as quickly as possible a
+first version of an ocean-atmosphere coupler. A more ``sovarphisticated
+method'' is beeing studied in parallel by Norman BARTH [2]. This method
+imposes the conservation of the field integral on each mesh of the coarser
+grid, and requires, in order to satisfy these multiple constraints, the
+mutiplication by matrices of the coarser grid size square for each
+interpolation. 
+
+A lot of the concepts which are used in the ``naive method'', comes from
+the ones that are considered in the ``sovarphisticated method'' [3,2], but retain
+only the low cost ones. The coupler will offer the possibility of choosing
+between the ``naive'' or ``sovarphisticated'' methods, depending on various
+constraints (memory space, computer time, efficiency, accuracy, etc...).
+Other methods, like the one of Philippe DANDIN [4], will also be pluged into
+the coupler. 
+
+
+
+
+
+\medskip
+
+
+
+
+
+The ``naive method'' can be summarized in few words:  knowing the values
+of a field on a source grid, the values on a point of the target grid is
+calculated by summing the values if its $L$th closest neighbors, with a
+weight which quicky decreases with the interdistance. 
+
+
+
+\medskip
+
+In Section 2, I recall the definition of the ``naive method'' in a concise
+way. In Section 3, I briefly
+describe the ``naive method library'', which is  the set of FORTRAN
+subroutines that I have written to implement the method, and focus on the
+visible part of the  iceberg that the coupler will need to know.  Some basic
+tests of this method are presented,  showing that there is no trivial bug
+left.   
+
+
+
+
+
+
+
+
+
+\beginsection 2.  THE NAIVE METHOD
+
+In Part A of this letter [1] general considerations about  grid-to-grid
+interpolation have been presented, and a ``simple  ocean-atmosphere  method'' have be
+presented in this general framework. Here I only present the materials
+necessary to its implementation. 
+
+
+
+\beginsection 2.1 Interpolation without constraints (SST) 
+
+Let $(b_j), j=1,N^b$ be the SST (sea surface temperature) on the ocean grid
+B,  defined by the points $(r^b_j), j=1,N^b$. Only the umasked points are
+considered in this definition of the grids and the following formula.  The
+values $(a_i), i=1,N^a$ of the SST on the atmospheric grid A,   defined by
+the points $(r^a_i), i=1,N^a$, are  given, in the naive method, by:
+$$
+a_i={1\over Z^b( r^a_i)} \sum_{m\in J(r_i^a)} b_i \;
+\phi\left( {\left| r_j^b-r_i^a\right| \over \sigma_b } \right) 
+\eqno(2.1)\; ,
+$$
+where $J(r)=\{j_1(r),  j_2(r), ..., j_{L^b}(r)\}$ is the set containing the
+indices of the $L^b$ closest neighbors $r_m^b$ in grid B, of a point $r$
+located anywhere, and the normalizing function $Z^b$, defined for all  grids
+points of the gird A is:
+$$
+ Z^b( r^a_i)= \sum_{m\in J(r_i^a)}  
+\phi\left( {\left| r_j^b-r_i^a\right| \over \sigma_b } \right)  \; .
+\eqno(2.2)
+$$
+
+
+
+In its present implementation the weight function $\phi$ is a gaussian: 
+$$
+\phi(u) = e^{-u^2 \over 2} 
+\eqno(2.3) \;.
+$$
+
+The variance $ \sigma_b$ is of the order one or two times the average
+mesh size  of the grid B.  Other choices of the weight functions are
+discussed below. 
+
+
+
+
+
+
+
+
+
+
+
+\beginsection 2.2 Summary of the Lagrangian formalism
+
+As explained in Part A [1], the extension of the above grid-to-grid
+interpolation to an interpolation with constraints can be defined through a
+formalism in which a Lagrangian functionnal is to be minimized under
+these constraints. 
+
+
+
+In this formalism, both the source grid A (on which $N^a$ values $a_i$ are
+known) and the target grid B (on which $N^b$ values $b_i$ are to be found)
+are associated to an interpolation which reads:
+
+$$
+f(r)= \sum_{i=1}^{N^a} a_i \varphi_i(r) 
+\eqno(2.4)
+$$
+for grid  A, which is made of $N^a$ grid points,  and
+$$
+g(r)= \sum_{j=1}^{N^b} b_j \psi_j(r) 
+\eqno(2.5)
+$$
+for grid  B, which is made of $N^b$ grid points. 
+
+
+
+If we impose that the equality of the integrals of the two functions $f$
+and $g$ (fluxes) on the two respective domains that the two grids are
+covering,  a constrained interpolation method is defined by the
+minimization of the Lagrangian:
+$$
+L(b_1,b_2,...,b_{N^b}) = \int [f(r)-g(r)]^2  \; dr + 
+\lambda \int [f(r)-g(r)] \; dr  
+\eqno(2.6)
+$$
+subject to the constraints $ \int [f(r)-g(r)] \; dr =0$. 
+
+With the matrix notations  $B=(b_j)$, $A=(a_i)$, $H=(\int \psi_j dr)$, $G=(\int
+\varphi_i dr)$ and $V=(\int \psi_m \psi_j dr)$, where $i=1,N^a$ and $j$
+or $m=1,N^b$, the solution of the minimization of $L$, subject to the
+constraint $HB=GA$, is given by $B=B^*-\lambda
+V^{-1}H$, where  $B^*= V^{-1}UA$ is the solution without constraint and
+$\lambda$,  the Lagragian multiplicator,  is given by 
+$$
+\lambda= { HB^*-GA \over HV^{-1}H} 
+\eqno(2.7) \;. 
+$$
+
+
+
+The solution with constraints reads, in its final form
+$$
+\eqalign{
+B=& B^* -{ HB^* - GA \over HV^{-1}H }  V^{-1}H \cr
+=& V^{-1}UA- {HV^{-1}UA - GA\over HV^{-1}H} V^{-1}H }
+\eqno(2.8) \;. 
+$$
+(NB: this expression
+and Equation 2.6 gives the errata of Equations 4.4, 4.6 and 4.7 of the first
+version {\bf 0615}  of the  Part A
+of this letter, now revised [1]). 
+
+\beginsection 2.3 Interpolation with one constraint (Flux)
+
+The easiest implementation of the above interpolation with constraint is
+obtained when $V$ is the unity matrix, that is when the interpolation
+associated with the target grid is the ``closest neighbor'' interpolation
+(see Part A [1] for details). 
+
+
+
+The above naive method, combined with this global conservation constraint
+of the integrals over the two domains (total fluxes) read: 
+
+$$
+b_j=b^*_j - \lambda  h_j  
+\eqno(2.9)
+$$
+where the unconstrained solution is 
+$$
+b^*_j={1\over Z^a( r^b_j)} \sum_{m\in I(r_j^b)} a_i 
+\phi\left( {\left| r_i^a-r_j^b\right| \over \sigma_a } \right) 
+\eqno(2.10)\; ,
+$$ 
+and the Lagrangian multiplier is given by 
+$$
+\lambda =  {\sum_{j=1}^{N^b} h_j b^*_j -   \sum_{i=1}^{N^a} g_i a^*_i 
+\over  \sum_{j=1}^{N^b} h_j h_j  }
+\eqno(2.11) 
+$$
+where $I(r)=\{i_1(r),  i_2(r), ..., i_{L^b}(r)\}$ is the set containing the indices
+of the $L^a$ closest neighbors $r_m^a$ in grid A, of a point $r$ located
+anywhere, and the normalizing function $Z^a$, defined for all  grids points
+of the gird B is:
+$$
+ Z^a( r^b_j)= \sum_{m\in I(r_j^b)}  
+\phi\left( {\left| r_i^a-r_j^b\right| \over \sigma_a } \right)  \; .
+\eqno(2.12)
+$$
+
+
+
+In the above expressions, $h_j$ is the area of the grid B meshes (see Part
+A [1]) and 
+$$
+g_i= \int  {1\over Z^a( r)} \phi\left( {\left|r- r_i^a\right| \over \sigma_a
+}\right)\; dr
+\eqno(2.12)
+$$ 
+
+In the present implementation of the software, these coefficients have been
+approximated by the surface of the meshes, i.e., $g_i$ is 
+ the surface of the set of all the points which admit $r_i^a$ as their
+ closest neighbor.   This is as if the closest neighbor
+interpolation were chosen in the constraint, while another  interpolation is
+chosen in the quadratic term of the Lagrangain.
+ However, in the future evolution of the
+software, more elabored values of $g_i$ will be possible. 
+
+ 
+
+
+
+\vfill\eject
+
+
+
+
+
+
+
+
+
+\beginsection 3. IMPLEMENTATION OF THE METHOD
+
+The above method have been implemented through a set of FORTRAN subroutines
+which constitutes the  ``naive method library''. Some practical details 
+are given in view of its use in the  coupler, or for testing purposes.
+ A first set of basic tests
+is shown, and the future evolution of this library is hinted. 
+
+
+
+\beginsection 3.1 The ``naive method library''
+
+The directory
+ {\tt greenh@cerfacs.fr:/usr1/pub/numlab/naiv} contains a software
+environment and a set of subroutines constituting the current
+implementation of the ``naive'' grid-to-grid interpolation method.  These
+FORTRAN subroutines have been written following the DOCTOR norm [5, 6].
+A main program performs various tests of these subroutines, and give
+examples of the use of theses subroutines.  
+
+
+
+\bigskip
+
+
+
+The initialization of the grids, the masks and the fields is dependant of the
+atmospheric and oceanic GCMs to be coupled, and will communicated by
+them to the coupler independantly of the interpolation task. However, the
+present library also contains subroutines which generates academic grids,
+masks or fields for testing purposes, and, so far, the initialization of a
+128x64 EMERAUDE grid, a 228x94 OPA-Pacific grid and some EMERAUDE
+fluxes. Extension to other realistic grids for testing purposes are planned. 
+
+
+\beginsection 3.2 A first draft for a manual 
+
+ This library is written is such a way that  only a few items
+need to be visible from the coupler. The names of these subroutines 
+start with {\tt NA}. These high level subroutines call basic subroutines
+with, most of the time, 
+a name starting with  {\tt PL}.
+A very preliminary draft is given through the name of these
+subroutines.
+
+
+\medskip
+\medskip
+\noindent{\bf Include files} 
+ \medskip
+
+These are, at first, three include files containing the commons which
+describe the grids:
+
+
+
+\medskip
+
+\item{}{\tt NAGRA.H}, containing the common for the arrays of grid A (e.g.
+atmsopheric). 
+
+
+
+\medskip
+
+\item{}{\tt NAGRB.H}, containing the common for the arrays grid B (e.g.
+ocean). 
+
+
+
+\medskip
+
+\item{}{\tt NAGAB.H}, containing the commons for the weight arrays used
+in  the grid-to-grid interpolations. 
+
+
+
+\medskip
+\medskip
+\noindent{\bf Grid initializations subroutines} 
+ \medskip
+
+The two first sets of commons of {\tt NAGRA.H} and {\tt NABRB.H}, for grid
+A and grid B, can be initialized by the subroutines: 
+
+
+
+\medskip
+
+\item{} {\tt NAGRDA },  to initialize idealized  A grids.
+
+
+
+\medskip
+
+\item{} {\tt NAGRDB },  to initialize idealized  B grids.
+
+
+
+\medskip
+
+\item{} {\tt NAGMRO },  to initialize the A grid from the EMERAUDE
+128x64 global grid. 
+
+
+
+\medskip
+
+\item{} {\tt NAGOPA},  to initialize idealized  B grid from the OPA
+226x94 Pacific grid. 
+
+
+
+
+\medskip
+\medskip
+\noindent{\bf Interpolations subroutines} 
+ \medskip
+
+The last set of common, in {\tt NAGAB.H} are calculated in the subourtine: 
+
+\medskip
+
+\item{} {\tt NASET(amesh,bmesh)},
+ to initialize the weight arrays of the  interpolation, given the variances
+of the weight functions {\tt amesh} and  {\tt amesh}.   
+
+
+\medskip
+
+
+
+Once the three initialisations are done, the grid A to grid B, and  grid  B to
+grid A interpolations are  performed by the two subroutines:
+
+
+
+\medskip
+
+
+
+\item{} {\tt NASST(ssta,sstb)}, to interpolate a field from grid B to
+grid A without constraint
+(e.g. the SST). 
+
+\medskip
+
+\item{} {\tt NAFLUX(fluxb,fluxa)}, to interpolate a field from grid A to
+grid B while conserving
+its average between the two unmasked domains (e.g., fluxes). 
+
+\medskip
+\medskip
+\noindent{\bf Basic subroutines} 
+ \medskip
+
+These suboutines are called by the higher level subroutines, and need not to
+be known by the first time user:
+
+
+{\tt
+PLDIS2.f  PLGPRI.f  PLGRDU.f  PLQQT.f   PLSCAR.f  PLSST.f   PLVISU.f
+
+
+PLFLUX.f  PLGRDC.f  PLINS.f   PLRHAL.f  PLSORT.f  PLSTAT.f
+
+
+PLGAUS.f  PLGRDP.f  PLMASQ.f  PLRHO.f   PLSSPH.f  PLTMRO.f
+
+
+IMPR.f   IMPRI.f
+}
+
+\medskip
+\medskip
+\noindent{\bf Testing  subroutines} 
+ \medskip
+
+
+Examples of the use of these ``coupler-visible'' subroutines (with names
+starting by {\tt NA}), or of the ``basic'' subroutines (with names starting by PL)
+can be found in several test performing subroutines: 
+
+\medskip
+
+\item{} {\tt NATFX(fluxb,fluxa)}:
+ call {\tt NAFLUX} and visualizes the fields.
+
+\medskip
+
+\item{} {\tt NATST(ssta,sstb)}: call {\tt NASST} and visualizes the fields.
+
+\medskip
+
+\item{} {\tt NATES1(flda,fldb,fldaa)}: calls 
+{\tt NASST} and then {\tt NAFLUX}, visualizes the fields, and compares the
+intial and final fields.  
+
+\medskip
+
+\item{} {\tt NATES2(flda,fldb,fldaa)}:  calls
+  {\tt NAFLUX} and then {\tt NASST}, and compares the
+intial and final fields. 
+\medskip
+
+\item{} {\tt NATES3(flda,fldb,fldaa,kvisuo}: calls  
+  {\tt NAFLUX} and  then {\tt NASST} and visualizes the fields in a way that
+allows animations. 
+Typically, the influence of the variance of the weight functions can be
+studied with this subroutine, through animation of the error field. 
+
+\medskip
+\medskip
+
+These testing subroutines  assume
+that the grids and the interpolation coefficients have already been
+initialized. 
+
+
+
+\beginsection 3.3 Tests of the grid-to-grid interpolation
+
+Various tests have been performed to check that the library of subroutines of
+was free of trivial tests. However, systematic tests of the performance of
+the ``naive method'' and its sensibility to its adjustable parameters (shape
+and variance of the weight functions, number of neighbours, relative
+positions of the masks, ...) still remain to be done. 
+
+
+
+\medskip
+
+In the following tests, the weight function $\phi$
+ is a Gaussian, with a uniform
+variance on a given grid. 
+
+\medskip
+
+
+
+The most trivial test was to check that with a one neighbour interpolation,
+and the same grid, the interpolation was giving the same field.  
+
+
+
+\medskip
+
+
+
+The second test has been made with an analytically generated field $f(x,y)=$
+$\cos (k1 x)$ $\cos(k_2 y)$ interpolation  forward (NAFLUX) an backward
+(NASST) between a cartesian square grid and a polar disk grid, with
+non-coincident masks.  Figure show an example in which 
+ small neighbour number has been given
+to the naive method. This test shows that the original field is well
+recovered, excepted, of course, in the regions where the mask are far from
+coincidence. 
+
+\medskip
+
+
+
+
+
+The third test  uses two grids of very different resolutions, with a mask
+defined by an analytical curve.  The case of a circle  is shown on Figure 2,
+and more complex contour should be used in future tests of this kind. 
+
+\medskip
+
+
+
+
+
+The fourth test (Figure 3) studies the interpolation between an
+analytically defined field $f(x,y)$ on the masked EMERAUDE grid
+(Atmospheric GCM) and the unmasked Pacific OPA (Ocean GCM).   In the
+forward interpolation (NAFLUX), the trace of the EMERAUDE mask can be
+seen on the unmasked OPA domain. In the backward direction (NASST), the
+original field is well recovered  on the tropical Pacific, and, of course,
+meaninless far from this region. 
+
+
+
+The last test  (Figure 4) deals with a realistic flux field (stress $\tau_ x$
+in the longitudinal direction) of EMERAUDE and shows it interpolation on
+the Pacific OPA masked grid. Comparison with Philippe Dandin's
+interpolation's method is under progress.                        
+
+
+
+\beginsection 3.4 Future developments
+
+In the  present state of the ``naive method library'',
+ the coupler-visible items  are
+ready  to be used in the coupler. However, they are at the
+stage of a $\beta$-release, and will be improved by furthers tunings.  The
+possibility of choosing weight functions which shape and variance can vary
+with the index of the grid point will be given. This will allow, for instance, 
+to use ``non-smoothing'' function, e.g. the  functions associated to the
+spectral method used on the grid [7]. This will also allow   to pay special
+attention to land-sea regions, or  implement interpolation method based on
+``wavelet decomposition''.  
+
+
+
+%The calculation of the grid surface elements is not yet  properly
+%implemented for spherical grids. 
+
+
+
+\beginsection 4. CONCLUSION 
+
+The present letter can be considered as a first draft of a user manual of
+the ``naive method''. A concise presentation
+ of the  method has been presented, 
+as well ot its possible future evolution. Pratical details for the
+use of the ``naive method library'' have been given in the spirit of its
+integration into the coupler. The names of testing subroutines which can be 
+read as examples have been given. 
+
+
+
+Further steps need to be done in order to reach a clean version of this
+``naive method library'', with a more complete user manual. However, these
+first steps in the organisation of a sofware product, with the respect of
+the DOCTOR norm, the separation between  subroutines ``visible''  from a
+calling code, with a minimal list of argument and extensive use of
+commons, and  ``basic'' subroutines free of commons, can be helpfull  for
+the organization of our future software development. Such an organization
+is also found in the ``Spectral Interface Library'' [8]. 
+
+
+
+\beginsection  Acknowledgments 
+
+I thank Dominique ASTRUC for helping to use his visualization software [9]
+with which the Figure have been produced. 
+
+
+
+
+\beginsection REFERENCES
+
+
+\def\ref{\parskip 12pt \leftskip 20pt \parindent -20pt} 
+\def\endref{\parskip 0pt \leftskip 0pt \parindent 20pt}
+
+
+\ref
+
+[1]
+O. THUAL, Simple  ocean-atmosphere  interpolation. Part A: the method, 
+ {\it Epicoa \ } {\bf 0315}  (1992).
+
+
+
+[2] 
+N. H. BARTH,  A Conservative Scheme for Passing Variables Between
+Coupled Models of the Ocean an Atmosphere
+ {\it Technical Report \ }, CERFACS (1992).
+
+
+
+[3] 
+O. THUAL, Gathering information for a coupler,
+ {\it Epicoa \ } {\bf 0119} (1992).
+
+
+
+
+[4] 
+P. DANDIN, th\`ese de doctorat, in preparation (1992). 
+
+
+
+[5] J. CLOCHARD, Norme de codage ``DOCTOR'' pour le projet ARPEGE,{\it Note de
+travail ``AREPEGE''}  {\bf No. 4} (1988). 
+
+
+
+[6] J. K. GIBSON, The Doctor system - A DOCumentary ORiented programming
+system, {\it ECMWF Technical Memorandum}  {\bf No. 52} (1982). 
+
+
+[7] P. BERNARDET, private communication (1992).
+
+[8]  O. THUAL, Spectral Interfaces Library Version 2.2,  CERFACS (1990).
+
+
+[9]  D. ASTRUC,  Visuo: manuel de l'utilisateur, {\it Internal Report}
+(1990). 
+ 
+\endref
+
+
+\vfill\eject
+\centerline{ Exchange of Projects and Ideas for Coupling Ocean and
+Atmosphere (Epicoa)}
+\centerline{ Appendix to Olivier Thual(8) , June 30$^{\rm th}$ 1992}
+ \bigskip
+
+
+\centerline{\bf  SOURCE OF THE NAIVE METHOD LIBRARY}
+ \bigskip
+
+\centerline{ Version naiv01,  92 06 30 } 
+
+
+
+\bigskip \bigskip
+
+This version is contained in {\tt
+greenh@cerfacs.fr:/usr1/pub/numlab/naiv/cnaiv01}
+
+\bigskip \bigskip
+
+
+
+\beginsection 1. Include files
+
+{\tt
+
+NAGAB.H  NAGRA.H  NAGRB.H
+
+
+}
+
+\beginsection 2. Main Program
+
+
+
+{\tt
+
+ANAIV.f
+
+}
+
+
+
+\beginsection 3. Coupler visible subroutines {\tt NA - - - -} 
+
+
+
+{\tt
+
+NAFLUX.f  NAGMRO.f  NAGRA.H   NAGRDA.f  NASET.f   NATES1.f  NATES3.f  NATST.f
+
+
+NAGAB.H   NAGOPA.f  NAGRB.H   NAGRDB.f  NASST.f   NATES2.f  NATFX.f
+
+
+
+}
+
+
+
+\beginsection 4. Basic  subroutines {\tt PL - - - -} 
+
+
+
+{\tt
+
+PLDIS2.f  PLGPRI.f  PLGRDU.f  PLQQT.f   PLSCAR.f  PLSST.f   PLVISU.f
+
+
+PLFLUX.f  PLGRDC.f  PLINS.f   PLRHAL.f  PLSORT.f  PLSTAT.f
+
+
+PLGAUS.f  PLGRDP.f  PLMASQ.f  PLRHO.f   PLSSPH.f  PLTMRO.f
+
+
+
+
+}
+
+
+
+\beginsection 5. Subroutine stolen from outside 
+
+
+
+{\tt
+
+IMPR.f   IMPRI.f
+
+
+}
+
+
+
+\end
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/expdlist.sty
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/expdlist.sty	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/expdlist.sty	(revision 1677)
@@ -0,0 +1,176 @@
+%%
+%% This is file `expdlist.sty',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% expdlist.dtx  (with options: `style')
+%% 
+%% This is a generated file.
+%% 
+%% Copyright 1992 1999 R. Huelse, W. Kaspar
+%% 
+%% This file is part of the expdlist package.
+%% ------------------------------------------
+%% 
+%% It can redistributed and/or modified under the terms
+%% of the LaTeX Project Public License Distributed from CTAN
+%% archives in directory macros/latex/base/lppl.txt; either
+%% version 1 of the License, or (at your option) any later version.
+%% 
+\def\filename{EXPDLIST}
+\def\filedate{22.09.1999}
+\def\fileversion{V 2.4}
+\def\docdate {22.09.99}
+%% \CheckSum{214}
+%% \CharacterTable
+%%  {Upper-case    \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z
+%%   Lower-case    \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z
+%%   Digits        \0\1\2\3\4\5\6\7\8\9
+%%   Exclamation   \!     Double quote  \"     Hash (number) \#
+%%   Dollar        \$     Percent       \%     Ampersand     \&
+%%   Acute accent  \'     Left paren    \(     Right paren   \)
+%%   Asterisk      \*     Plus          \+     Comma         \,
+%%   Minus         \-     Point         \.     Solidus       \/
+%%   Colon         \:     Semicolon     \;     Less than     \<
+%%   Equals        \=     Greater than  \>     Question mark \?
+%%   Commercial at \@     Left bracket  \[     Backslash     \\
+%%   Right bracket \]     Circumflex    \^     Underscore    \_
+%%   Grave accent  \`     Left brace    \{     Vertical bar  \|
+%%   Right brace   \}     Tilde         \~}
+%%
+
+\typeout{Document Substyle `EXPDLIST'.
+         Released \filedate \space (\fileversion)}
+\typeout{English Documentation \space \docdate}
+\def\compact%
+   {\setlength{\itemsep}{-\parsep}}
+\def\setleftmargin%
+   #1%
+   {\setlength{\leftmargin}{#1}}
+\let\setlabelsize = \setleftmargin
+\def\setlabelphantom%
+   #1%
+   {\def\set@labelphantom%
+     {\setbox\@tempboxa=\hbox spread \labelsep {\@labelstyle #1\hfil}%
+      \setleftmargin{\wd\@tempboxa}%
+     }%
+   }
+\def\set@labelphantom{}
+\def\@labelstyle%
+   {\bfseries}
+\def\setlabelstyle%
+   #1%
+   {\def\@labelstyle{#1}}
+\def\breaklabel%
+   {\def\@breaklabel%
+       {\rule{0mm}{0mm}%
+        \\%
+       }%
+   }%
+\def\@breaklabel%
+   {}
+\let\@orgdlist\description
+\def\description%
+   {\@ifnextchar[%
+       {\@expdlist}%
+       {\@orgdlist}%
+   }
+\let\enddescription\endlist
+\def\@expdlistlabel#1%
+    {\@labelstyle
+     #1%
+     \hfil%
+    }
+\def\@expdlist[#1]%
+    {\list{}%
+      {\def\@breaklabel{}%
+       \def\set@labelphantom{}%
+       \def\@labelstyle{\bfseries}%
+       #1%
+       \set@labelphantom%
+       \setlength{\labelwidth}{\leftmargin}%
+       \addtolength{\labelwidth}{-\labelsep}%
+       \let\makelabel\@expdlistlabel%
+      }%
+    }
+\newlength{\listpartsep}
+\listpartsep = 1ex
+\long\def\listpart%
+   #1%
+   {\vspace{\listpartsep}%
+    \item[]\hspace*{-\leftmargin}%
+    \@tempskipa=\linewidth%
+    \addtolength{\@tempskipa}{\rightmargin}%
+    \addtolength{\@tempskipa}{\leftmargin}%
+    \parbox{\@tempskipa}{#1}%
+    \vspace{\listpartsep}%
+   }
+\def\@item[#1]{%
+  \if@noparitem
+    \@donoparitem
+  \else
+    \if@inlabel
+      \indent \par
+    \fi
+    \ifhmode
+      \unskip\unskip \par
+    \fi
+    \if@newlist
+      \if@nobreak
+        \@nbitem
+      \else
+        \addpenalty\@beginparpenalty
+        \addvspace\@topsep
+        \addvspace{-\parskip}%
+      \fi
+    \else
+      \addpenalty\@itempenalty
+      \addvspace\itemsep
+    \fi
+    \global\@inlabeltrue
+  \fi
+  \everypar{%
+    \@minipagefalse
+    \global\@newlistfalse
+    \if@inlabel
+      \global\@inlabelfalse
+      {\setbox\z@\lastbox
+       \ifvoid\z@
+         \kern-\itemindent
+       \fi}%
+      \box\@labels
+      \penalty\z@
+    \fi
+    \if@nobreak
+      \@nobreakfalse
+      \clubpenalty \@M
+    \else
+      \clubpenalty \@clubpenalty
+      \everypar{}%
+    \fi}%
+  \if@noitemarg
+    \@noitemargfalse
+    \if@nmbrlist
+      \refstepcounter\@listctr
+    \fi
+  \fi
+  \sbox\@tempboxa{\makelabel{#1}}%
+  \global\setbox\@labels\hbox{%
+    \unhbox\@labels
+    \hskip \itemindent
+    \hskip -\labelwidth
+    \hskip -\labelsep
+    \ifdim \wd\@tempboxa >\labelwidth
+      \box\@tempboxa
+      \gdef\set@break{\@breaklabel}     % RUM Change 2.3.90
+    \else
+      \hbox to\labelwidth {\unhbox\@tempboxa}%
+      \gdef\set@break{}%                % RUM Change 2.3.90
+    \fi
+    \hskip \labelsep}%
+    \set@break                          % RUM Change 2.3.90
+  \ignorespaces}
+\endinput
+%%
+%% End of file `expdlist.sty'.
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/oasis3doc.tex
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/oasis3doc.tex	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/oasis3doc.tex	(revision 1677)
@@ -0,0 +1,75 @@
+\documentclass[rs,english,toc,lot,lof,index,wide,overfull]{prismdoc}
+%====================================
+% PRISMDOC: Start Dokument Information
+%====================================
+\usepackage{longtable}
+\usepackage{natbib}
+\usepackage{verbatim}
+\usepackage{epsfig}
+\usepackage{rotating}
+\usepackage{graphicx}
+\usepackage{amssymb}
+%
+% Specifications for cover pages: 
+%
+\prismdocNum{Report No 2}
+\prismdocTitel{{\fontsize{13}{16}\selectfont
+    OASIS3 User Guide \\ [0.5ex]
+    \it{prism\_2-4 }}}
+\prismdocAutor{Edited by:  \\ [0.5ex]
+            S. Valcke, CERFACS  \\[0.5ex]
+	    A. Caubel, FSE  \\[0.5ex]
+	    R. Vogelsang, SGI Germany \\[0.5ex]
+	    D. Declat, CERFACS\\[0.5ex]
+}
+\prismdocVersion{5$^th$ Edition}
+\prismdocFName{Sophie Valcke}
+\prismdocFAff{CERFACS}
+%\prismdocFEM{toto}
+%\prismdocFem{x@cerfacs.fr, with x=oasishelp} 
+%\prismdocSName{Ren\'e Redler}
+\prismdocFPhone{+33-5-61-19-30-76}
+%\prismdocSPhone{+49-2241-92-52-40}
+%\prismdocFWp{wpnn}
+%\prismdocSWp{wpnn}
+\prismdocDate{December 21, 2004}
+
+
+%====================================
+% PRISMDOC: End Dokument Information
+%====================================
+\newcommand{\antispace}{\vspace*{-2ex}}
+\newcommand{\bigspace}{\vspace*{+4ex}}
+\newcommand{\medspace}{\vspace*{+2ex}}
+\newcommand{\smallspace}{\vspace*{+0ex}}
+\newcommand{\marginlabel}[1]{\mbox{}\marginpar{\raggedleft\hspace{0pt}#1}}
+\newcommand{\imprt}{\marginlabel{{\bfseries\Huge !}}}
+\newcommand{\imprtbig}{\marginlabel{{\bfseries\Huge !}}}
+\newcommand{\bignote}{\marginlabel{{\bfseries\Huge !!!}}}
+\newcommand{\imprtsm}{\marginlabel{{\bfseries\LARGE !}}}
+\newcommand{\imnote}{\marginlabel{{\bfseries\LARGE !!!}}}
+\newcommand{\bcntr}{\begin{center}}
+\newcommand{\ecntr}{\end{center}}
+
+%\includeonly{documentation}
+\begin{document}
+\prismdocHeader
+
+\include{defines}
+\include{UG_Acknowledgements}
+\include{UG0_Stepbystep_overview}
+\include{UG1_Obtaining}
+\include{UG2_Model_interfacing}
+\include{UG3_Namcouple_generation}
+\include{UG4_Transformations}
+\include{UG5_Auxiliary_files}
+\include{UG6_Compilation_running}
+% > appendices
+\include{UGA1_Grid_description}
+\include{UGA4_changes}
+\include{UGA2_SCRIP}
+\include{UGA3_couplings}
+
+\include{UGRefs}
+
+\end{document}
Index: CPL/oasis3/trunk/src/mod/oasis3/doc/prismdoc.cls
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/doc/prismdoc.cls	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/doc/prismdoc.cls	(revision 1677)
@@ -0,0 +1,817 @@
+
+%%
+%% This is file `prismdoc.cls'; there should be no need for modifications
+%%
+
+\def\fileversion{0.8}
+\def\filedate{2004/07/26}
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesClass{prismdoc}[2004/07/26 For all prismdoc manuals]
+\RequirePackage{ifthen}
+
+\newboolean{IsItaIB}\setboolean{IsItaIB}{false}
+\newboolean{IsItaRS}\setboolean{IsItaRS}{false}
+\newboolean{IsItaDOCU}\setboolean{IsItaDOCU}{false}
+\newboolean{IsItaZIK}\setboolean{IsItaZIK}{false}
+\newboolean{IsItaZHB}\setboolean{IsItaZHB}{false}
+\newboolean{OptSectoChap}\setboolean{OptSectoChap}{false}
+\newboolean{OptChaptoSec}\setboolean{OptChaptoSec}{false}
+\newboolean{OptToc}\setboolean{OptToc}{false}
+\newboolean{OptNoArabic}\setboolean{OptNoArabic}{false}
+\newboolean{OptIndex}\setboolean{OptIndex}{false}
+\newboolean{OptFigureList}\setboolean{OptFigureList}{false}
+\newboolean{OptTableList}\setboolean{OptTableList}{false}
+\newboolean{OptExampleList}\setboolean{OptExampleList}{false}
+\newboolean{OptProgramList}\setboolean{OptProgramList}{false}
+\newboolean{OptJobList}\setboolean{OptJobList}{false}
+\newboolean{OptOldFloat}\setboolean{OptOldFloat}{false}
+\newboolean{OptLow}\setboolean{OptLow}{false}
+\newboolean{OptWide}\setboolean{OptWide}{false}
+\newboolean{OptNocopy}\setboolean{OptNocopy}{false}
+\newboolean{OptTitleonly}\setboolean{OptTitleonly}{false}
+
+\newcommand{\PRISMDOCZikTitle}{PRISM-interne Kurzinformation}
+\newcommand{\PRISMDOCZhbTitle}{PRISM-internes Handbuch}
+\newcommand{\PRISMDOCIbTitle}{Interner Bericht}
+\newcommand{\PRISMDOCtype}{}
+\newcommand{\PRISMDOCDebugBox}[1]{}
+\newcommand{\PRISMDOCFont}[6]{\fontencoding{#1}\fontfamily{#2}\fontseries{#3}
+                               \fontshape{#4}\fontsize{#5}{#6}\selectfont}
+
+\DeclareOption*{%
+  \typeout{PRISMDOC: \CurrentOption\ passed to base class}
+  \PassOptionsToClass{\CurrentOption}{article}%
+  \PassOptionsToClass{\CurrentOption}{report}%
+  }
+\DeclareOption{a4paper}{\typeout{PRISMDOC:
+    {\CurrentOption}  will not be used}}
+\DeclareOption{a5paper}{\typeout{PRISMDOC:
+    {\CurrentOption}  will not be used}}
+\DeclareOption{sectochap}{
+  \setboolean{OptSectoChap}{true}
+  }
+\DeclareOption{chaptosec}{
+  \setboolean{OptChaptoSec}{true}
+  }
+\DeclareOption{rs}{
+% middle part of Doc Type:e.g.Report
+  \renewcommand{\PRISMDOCtype}{}
+  \setboolean{IsItaRS}{true}
+  \setboolean{OptChaptoSec}{false}
+  }
+\DeclareOption{tki}{
+  \renewcommand{\PRISMDOCtype}{TKI}
+  }
+
+\DeclareOption{zik}{
+  \renewcommand{\PRISMDOCtype}{ZIK}
+  \setboolean{IsItaZIK}{true}
+  }
+\DeclareOption{zhb}{
+  \renewcommand{\PRISMDOCtype}{ZHB}
+  \setboolean{IsItaRS}{true}
+  \setboolean{IsItaZHB}{true}
+  }
+\DeclareOption{ib}{
+  \renewcommand{\PRISMDOCtype}{IB}
+  \setboolean{IsItaRS}{true}
+  }
+\DeclareOption{toc}{
+  \setboolean{OptToc}{false}
+  }
+\DeclareOption{noarabic}{
+  \setboolean{OptNoArabic}{true}
+  }
+\DeclareOption{lof}{
+  \setboolean{OptFigureList}{false}
+  }
+\DeclareOption{lot}{
+  \setboolean{OptTableList}{false}
+  }
+\DeclareOption{loe}{
+  \setboolean{OptExampleList}{false}
+  }
+\DeclareOption{lop}{
+  \setboolean{OptProgramList}{false}
+  }
+\DeclareOption{loj}{
+  \setboolean{OptJobList}{false}
+  }
+\DeclareOption{english}{
+  \renewcommand{\PRISMDOCZikTitle}{PRISM internal Technical Reference}
+  \renewcommand{\PRISMDOCZhbTitle}{PRISM Internal User's Manual}
+  \renewcommand{\PRISMDOCIbTitle}{Technical Report}
+  }
+\DeclareOption{index}{
+  \setboolean{OptIndex}{true}
+  }
+\DeclareOption{nocopy}{
+  \setboolean{OptNocopy}{true}
+  }
+\DeclareOption{docurs}{
+  \renewcommand{\PRISMDOCtype}{Report}
+  \setboolean{IsItaRS}{true}
+  \setboolean{IsItaDOCU}{true}
+  }
+\DeclareOption{docu}{
+  \setboolean{IsItaDOCU}{true}
+  }
+\DeclareOption{titleonly}{
+  \setboolean{OptTitleonly}{true}
+  }
+\DeclareOption{overfull}{
+  \setlength{\overfullrule}{2pt}
+  }
+\DeclareOption{debug}{
+  \renewcommand{\PRISMDOCDebugBox}[1]{#1}
+  }
+\DeclareOption{oldfloat}{
+  \setboolean{OptOldFloat}{true}
+  }
+\DeclareOption{low}{
+  \setboolean{OptLow}{true}
+  }
+\DeclareOption{wide}{
+  \setboolean{OptWide}{true}
+  }
+\ProcessOptions\relax
+\ifthenelse{\boolean{IsItaRS}}
+{%
+  \LoadClass[twoside,11pt]{report}
+}% else
+{
+  {
+    \typeout{PRISMDOC: No document type found, assuming RS}
+    \LoadClass[twoside,11pt]{report}
+    }
+}
+\RequirePackage{varioref}
+\RequirePackage{times}
+\RequirePackage{tabularx}
+\RequirePackage{fancyheadings}
+\RequirePackage{float}
+\RequirePackage[hang,bf,small,nooneline]{caption}
+\RequirePackage{expdlist}
+\RequirePackage{varioref}
+\RequirePackage{multicol}
+\RequirePackage{changebar}
+\RequirePackage{alltt}
+\newcolumntype{C}{>{\centering\arraybackslash}X}%
+\newcommand{\htmladdnormallink}[2]{#1}
+\RequirePackage[dvips]{epsfig}
+\ifthenelse{\boolean{OptIndex}}%
+{
+  \RequirePackage{makeidx}
+}{}
+\ifthenelse{\boolean{OptChaptoSec}}
+{%
+\newcommand\chapter{\@startsection {section}{1}{\z@}%
+                                   {-3.5ex \@plus -1ex \@minus -.2ex}%
+                                   {2.3ex \@plus.2ex}%
+                                   {\normalfont\Large\bfseries}}
+\renewcommand\section{\@startsection{subsection}{2}{\z@}%
+                                     {-3.25ex\@plus -1ex \@minus -.2ex}%
+                                     {1.5ex \@plus .2ex}%
+                                     {\normalfont\large\bfseries}}
+\renewcommand\subsection{\@startsection{subsubsection}{3}{\z@}%
+                                     {-3.25ex\@plus -1ex \@minus -.2ex}%
+                                     {1.5ex \@plus .2ex}%
+                                     {\normalfont\normalsize\bfseries}}
+\renewcommand\subsubsection{\@startsection{paragraph}{4}{\z@}%
+                                    {3.25ex \@plus1ex \@minus.2ex}%
+                                    {-1em}%
+                                    {\normalfont\normalsize\bfseries}}
+\renewcommand\paragraph{\@startsection{subparagraph}{5}{\parindent}%
+                                       {3.25ex \@plus1ex \@minus .2ex}%
+                                       {-1em}%
+                                      {\normalfont\normalsize\bfseries}}
+\renewcommand\subparagraph{\@startsection{subparagraph}{5}{\parindent}%
+                                       {3.25ex \@plus1ex \@minus .2ex}%
+                                       {-1em}%
+                                      {\normalfont\normalsize\bfseries}}
+}{}
+\ifthenelse{\boolean{OptSectoChap}}
+{%
+\renewcommand{\section}{\if@openright\cleardoublepage\else\clearpage\fi
+                    \thispagestyle{plain}%
+                    \global\@topnum\z@
+                    \@afterindentfalse
+                    \secdef\@chapter\@schapter}
+\renewcommand{\subsection}{\@startsection {section}{1}{\z@}%
+                                   {-3.5ex \@plus -1ex \@minus -.2ex}%
+                                   {2.3ex \@plus.2ex}%
+                                   {\normalfont\Large\bfseries}}
+\renewcommand{\subsubsection}{\@startsection{subsection}{2}{\z@}%
+                                     {-3.25ex\@plus -1ex \@minus -.2ex}%
+                                     {1.5ex \@plus .2ex}%
+                                     {\normalfont\large\bfseries}}
+\renewcommand{\paragraph}{\@startsection{subsubsection}{3}{\z@}%
+                                     {-3.25ex\@plus -1ex \@minus -.2ex}%
+                                     {1.5ex \@plus .2ex}%
+                                     {\normalfont\normalsize\bfseries}}
+\renewcommand{\subparagraph}{\@startsection{paragraph}{4}{\z@}%
+                                    {3.25ex \@plus1ex \@minus.2ex}%
+                                    {-1em}%
+                                    {\normalfont\normalsize\bfseries}}
+}{}
+\voffset=-1in
+\hoffset=-1in
+\ifthenelse{\boolean{OptWide}}%
+{ %
+  \textwidth=16.2cm
+  \oddsidemargin=2.4cm
+  \evensidemargin=2.4cm
+}{ % else
+  \textwidth=15.2cm
+  \oddsidemargin=2.9cm
+  \evensidemargin=2.9cm
+}
+\topmargin=1.4cm
+\headheight=0.8cm
+\headsep=0.3cm
+\textheight=24.5cm
+\footskip=1.3cm
+\marginparwidth=1cm
+\setcounter{topnumber}{3}
+\setcounter{bottomnumber}{3}
+\setcounter{totalnumber}{6}
+\renewcommand{\topfraction}{0.8}
+\renewcommand{\bottomfraction}{0.8}
+\renewcommand{\textfraction}{0.1}
+\setlength\parskip{0.5ex \@plus 0.2ex}
+\setlength\parindent{0pt}
+\def\@listI{\leftmargin\leftmargini
+            \parsep \parskip
+            \topsep \z@
+            \itemsep\z@}
+\let\@listi\@listI
+\@listi
+\def\@listii {\leftmargin\leftmarginii
+              \labelwidth\leftmarginii
+              \advance\labelwidth-\labelsep
+              \topsep    \z@
+              \parsep    \parskip
+              \itemsep   \z@}
+\def\@listiii{\leftmargin\leftmarginiii
+              \labelwidth\leftmarginiii
+              \advance\labelwidth-\labelsep
+              \topsep    \z@
+              \parsep    \parskip
+              \partopsep \z@
+              \itemsep   \topsep}
+\def\@listiv {\leftmargin\leftmarginiv
+              \labelwidth\leftmarginiv
+              \advance\labelwidth-\labelsep}
+\def\@listv  {\leftmargin\leftmarginv
+              \labelwidth\leftmarginv
+              \advance\labelwidth-\labelsep}
+\def\@listvi {\leftmargin\leftmarginvi
+              \labelwidth\leftmarginvi
+              \advance\labelwidth-\labelsep}
+\hfuzz=2mm
+\newcommand{\PRISMDOCnum}{}
+\newcommand{\PRISMDOCautor}{}
+\newcommand{\PRISMDOCfname}{}
+\newcommand{\PRISMDOCsname}{}
+\newcommand{\PRISMDOCfphone}{}
+\newcommand{\PRISMDOCsphone}{}
+\newcommand{\PRISMDOCfwp}{}
+\newcommand{\PRISMDOCfaff}{}
+\newcommand{\PRISMDOCsaff}{}
+\newcommand{\PRISMDOCfem}{}
+\newcommand{\PRISMDOCswp}{}
+\newcommand{\PRISMDOCdate}{}
+\newcommand{\PRISMDOCversion}{}
+\newcommand{\PRISMDOCtitel}{}
+\newcommand{\PRISMDOCremark}{}
+\newcommand{\PRISMDOCfigsize}{}
+\newcommand{\prismdocType}[1]{\renewcommand{\PRISMDOCtype}{#1}}
+\newcommand{\prismdocNum}[1]{\renewcommand{\PRISMDOCnum}{#1}}
+\newcommand{\prismdocAutor}[1]{\renewcommand{\PRISMDOCautor}{#1}}
+\newcommand{\prismdocFName}[1]{\renewcommand{\PRISMDOCfname}{#1}}
+\newcommand{\prismdocSName}[1]{\renewcommand{\PRISMDOCsname}{#1}}
+\newcommand{\prismdocFPhone}[1]{\renewcommand{\PRISMDOCfphone}{#1}}
+\newcommand{\prismdocSPhone}[1]{\renewcommand{\PRISMDOCsphone}{#1}}
+\newcommand{\prismdocFWp}[1]{\renewcommand{\PRISMDOCfwp}{#1}}
+\newcommand{\prismdocSWp}[1]{\renewcommand{\PRISMDOCswp}{#1}}
+\newcommand{\prismdocFAff}[1]{\renewcommand{\PRISMDOCfaff}{#1}}
+\newcommand{\prismdocSAff}[1]{\renewcommand{\PRISMDOCsaff}{#1}}
+\newcommand{\prismdocFEm}[1]{\renewcommand{\PRISMDOCfem}{#1}}
+\newcommand{\prismdocVersion}[1]{\renewcommand{\PRISMDOCversion}{#1}}
+\newcommand{\prismdocDate}[1]{\renewcommand{\PRISMDOCdate}{#1}}
+\newcommand{\prismdocTitel}[1]{\renewcommand{\PRISMDOCtitel}{#1}}
+\newcommand{\prismdocRemark}[1]{\renewcommand{\PRISMDOCremark}{#1}}
+\newcommand{\prismdocFigSize}[1]{\renewcommand{\PRISMDOCfigsize}{#1}}
+
+\newcommand{\prismdocHeader}{}
+\newcommand{\prismdocTOC}{}
+
+\ifthenelse{\boolean{IsItaRS}}
+{%
+  \pagestyle{fancy}
+  \lhead[{\bfseries\thepage}]{\bfseries\rightmark}
+  \rhead[{\bfseries\leftmark}]{\bfseries\thepage}
+  \lfoot[{}]{}
+  \cfoot{}{}
+  \setlength{\headrulewidth}{0.4pt}
+  \ifthenelse{\boolean{OptIndex}}
+  {%
+    \makeindex
+    }{}
+  \renewcommand{\prismdocHeader}{%
+    \ifthenelse{\boolean{IsItaDOCU}}{
+    %  Title page
+      \thispagestyle{empty}
+      \setlength{\unitlength}{1cm}
+      \ifthenelse{\boolean{OptWide}}%
+      {\hspace*{5mm}}{}%
+      \newpage
+      \thispagestyle{empty}
+      \ \ \\
+      \newpage
+      }{}
+    \thispagestyle{empty}
+    \setlength{\unitlength}{1cm}
+    \ifthenelse{\boolean{OptWide}}%
+    {\hspace*{5mm}}{}%
+    \begin{picture}(15.2,24.5)
+      \ifthenelse{\not\(\boolean{IsItaIB}\or \boolean{IsItaDOCU}\)}%
+      {
+        \PRISMDOCDebugBox{\put(0,0){\dashbox{0.1}(15.2,24.5){}}}
+        \PRISMDOCDebugBox{\put(2.5,8.1){\dashbox{0.1}(10.3,10.3){}}}
+        \PRISMDOCDebugBox{\put(1.6,22.1){\dashbox{0.1}(12,2){}}}
+        \put(1.6,22.1){\makebox(12,2){\parbox{12cm}{
+              \begin{center}
+                \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{b}{n}{14pt}{18pt}
+                PRISM \\ 
+                Project for Integrated Earth System Modelling \\ }
+              {\PRISMDOCFont{T1}{ptm}{b}{n}{12pt}{14pt}
+                An Infrastructure Project for Climate Research in Europe \\
+                funded by the European Commission \\
+                under Contract  EVR1-CT2001-40012 \par
+                }
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Logo
+      \PRISMDOCDebugBox{\put(4.35,18.8){\dashbox{0.1}(6.5,0.5)[t]{}}}
+      \put(4.35,18.8){\makebox(6.5,0.5)[t]{
+          \parbox{6.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+               \centering
+                \includegraphics[width=4cm]{figures/prismnewlg}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Title
+        \PRISMDOCDebugBox{\put(2.8,9.3){\dashbox{0.1}(9.6,2.5)[t]{}}}
+        \put(2.8,9.3){\makebox(9.6,2.5)[t]{
+            \parbox{9cm}{
+              \begin{center}
+                \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{b}{n}{14pt}{18pt}
+                \PRISMDOCtitel\par}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Authors
+      \PRISMDOCDebugBox{\put(3.1,7.3){\dashbox{0.1}(9,1.5)[t]{}}}
+      \put(3.1,7.3){\makebox(9,1.5)[t]{
+          \parbox{15cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{sl}{11pt}{12pt}
+                \PRISMDOCautor\par}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Volume
+      \PRISMDOCDebugBox{\put(5.35,3.3){\dashbox{0.1}(4.5,0.4)[t]{}}}
+      \put(5.35,3.3){\makebox(4.5,0.4)[t]{
+          \parbox{4.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                PRISM-\PRISMDOCtype-\PRISMDOCnum}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Edition
+      \PRISMDOCDebugBox{\put(4.35,1.1){\dashbox{0.1}(6.5,0.4)[t]{}}}
+      \put(4.35,1.1){\makebox(6.5,0.4)[t]{
+          \parbox{6.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                \PRISMDOCversion}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Last changed: ??
+      \PRISMDOCDebugBox{\put(4.35,2.3){\dashbox{0.1}(6.5,0.5)[t]{}}}
+%S.L. left coordinate of box=\put(N.N,...)
+%S.L. height of lower frame=\put(...,N.N)
+%S.L. width of text box= \parbox{N.Ncm} 
+\put(4.35,0.3){\makebox(6.5,0.5)[t]{ 
+          \parbox{6.5cm}{   
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                \PRISMDOCdate }
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % Notes
+      \PRISMDOCDebugBox{\put(0,1.4){\dashbox{0.1}(13,1.5)[t]{}}}
+      \put(0,1.4){\makebox(13,1.5)[t]{
+          \parbox{13cm}{
+            {\PRISMDOCFont{T1}{ptm}{m}{n}{10pt}{12pt}\PRISMDOCremark}}}}
+      }{ % else
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+                                % IB: RS oder ZHB
+      \PRISMDOCDebugBox{\put(3.1,14.3){\dashbox{0.1}(9,0.9)[t]{}}}
+      \put(3.1,14.3){\makebox(9,0.9)[t]{
+          \parbox{9cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                \ifthenelse{\boolean{IsItaZHB}}%
+                  {\PRISMDOCZhbTitle}%
+                  {%
+                    \ifthenelse{\boolean{IsItaIB}}%
+                    {\PRISMDOCIbTitle}%
+                    }%
+                  }%
+                \vspace*{-\topsep}
+              \end{center}}}}
+                                % IB: Title
+        \PRISMDOCDebugBox{\put(2.6,10.8){\dashbox{0.1}(10.0,2.5)[t]{}}}
+        \put(2.6,10.8){\makebox(10.0,2.5)[t]{
+            \parbox{9cm}{
+              \begin{center}
+                \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{b}{n}{14pt}{18pt}
+                \PRISMDOCtitel\par}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % IB: Authors
+      \PRISMDOCDebugBox{\put(3.1,8.0){\dashbox{0.1}(9,1.5)[t]{}}}
+      \put(3.1,8.0){\makebox(9,1.5)[t]{
+          \parbox{9cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{sl}{11pt}{12pt}
+                \PRISMDOCautor\par}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % IB: Volume
+      \PRISMDOCDebugBox{\put(5.35,7.0){\dashbox{0.1}(4.5,0.4)[t]{}}}
+      \put(5.35,7.0){\makebox(4.5,0.4)[t]{
+          \parbox{4.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                PRISM-\PRISMDOCtype-\PRISMDOCnum}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % IB: Edition
+      \PRISMDOCDebugBox{\put(4.35,5.1){\dashbox{0.1}(6.5,0.4)[t]{}}}
+      \put(4.35,5.1){\makebox(6.5,0.4)[t]{
+          \parbox{6.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                \PRISMDOCversion}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % IB: Last changed
+      \PRISMDOCDebugBox{\put(4.35,6.3){\dashbox{0.1}(6.5,0.5)[t]{}}}
+      \put(4.35,6.3){\makebox(6.5,0.5)[t]{
+          \parbox{6.5cm}{
+            \begin{center}
+              \vspace*{-\topsep}
+              {\PRISMDOCFont{T1}{ptm}{m}{n}{12pt}{14pt}
+                (last change: \PRISMDOCdate)}
+              \vspace*{-\topsep}
+            \end{center}}}}
+                                % IB: Remark
+      \PRISMDOCDebugBox{\put(0,1.4){\dashbox{0.1}(13,1.5)[t]{}}}
+      \put(0,1.4){\makebox(13,1.5)[t]{
+          \parbox{15cm}{
+            {\PRISMDOCFont{T1}{ptm}{m}{n}{10pt}{12pt}\PRISMDOCremark}}}}
+      }
+      \end{picture}
+\newpage
+    \thispagestyle{empty}
+    \ifthenelse{\boolean{OptWide}}%
+    {\hspace*{5mm}}{}
+    \begin{picture}(15.2,24.5)
+                                % Body for Text
+    \PRISMDOCDebugBox{\put(0,0){\dashbox{0.1}(15.2,24.9){}}}
+
+    \ifthenelse{\boolean{IsItaIB}}{}%else
+    {
+    \PRISMDOCDebugBox{\put(0,21.4){\dashbox{0.1}(15,3.4)[t]{}}}
+    \ifthenelse{\boolean{OptNocopy}}{}%else
+    {
+      \put(0,21.4){\makebox(15,3.4)[t]{
+          \parbox{15cm}{
+            {\PRISMDOCFont{T1}{ptm}{b}{n}{12pt}{14pt}Copyright Notice\\[0.5ex]}
+            \PRISMDOCFont{T1}{ptm}{m}{n}{11pt}{13pt}
+            \copyright\ Copyright 2004 by CERFACS \\
+            All rights reserved.\\
+            No parts of this document should be either reproduced or 
+            commercially used without prior agreement 
+            by CERFACS representatives.  \\
+            }}}
+      }
+
+      \PRISMDOCDebugBox{\put(0,16.2){\dashbox{0.1}(15,5.2)[t]{}}}
+      \put(0,16.2){\makebox(15,5.2)[t]{
+          \parbox{15cm}{
+            {\PRISMDOCFont{T1}{ptm}{b}{n}{12pt}{14pt}
+              How to get assistance?\\[0.5ex]}
+            \PRISMDOCFont{T1}{ptm}{m}{n}{11pt}{13pt}
+            Assistence can be obtained as listed below. \\
+            PRISM documentations can be downloaded from
+            the WWW PRISM web site under the URL:
+            <http://prism.enes.org>
+            }}}
+
+      \PRISMDOCDebugBox{\put(0,14.4){\dashbox{0.1}(15,2.2)[t]{}}}
+      \put(0,16.6){\makebox(15,2.2)[t]{
+          \parbox{15cm}{
+            {\PRISMDOCFont{T1}{ptm}{b}{n}{12pt}{14pt}
+              Phone Numbers and Electronic Mail Adresses
+              \\[0.5ex]}
+%            \PRISMDOCFont{T1}{ptm}{m}{n}{11pt}{13pt}
+%            Electronic mail adresses of the individual work packages are composed as follows :\\
+%            \textbf{prism\_ \textit{work package} @prism.enes.org}
+            }}}
+
+      \PRISMDOCDebugBox{\put(0,4.1){\dashbox{0.1}(15,11.0)[t]{}}}
+      \put(0,7.1){\makebox(15,11.0)[t]{
+          \parbox{15cm}{
+            \newcommand{\PRISMDOCtblbf}{\PRISMDOCFont{T1}{ptm}{b}{n}{9.8pt}{11pt}}
+            \newcommand{\PRISMDOCtblit}{\PRISMDOCFont{T1}{ptm}{m}{it}{9.8pt}{11pt}}
+            \newcommand{\PRISMDOCtblbi}{\PRISMDOCFont{T1}{ptm}{b}{it}{9.8pt}{11pt}}
+            \PRISMDOCFont{T1}{ptm}{m}{n}{9.8pt}{11pt}
+            \renewcommand{\arraystretch}{1.11}
+            \setlength{\tabcolsep}{4pt}
+            \begin{tabular}[t]{|p{4.6cm}|p{3.1cm}|p{2.2cm}|p{3.1cm}|}
+              \hline%\rowcolor[gray]{0.2}
+              \PRISMDOCtblbf Name&
+              \PRISMDOCtblbf Phone &
+              \PRISMDOCtblbf Affiliation & 
+              \PRISMDOCtblbf e-mail \\ 
+              \hline\hline
+              \PRISMDOCfname\par & \PRISMDOCfphone\par & \PRISMDOCfaff\par & \PRISMDOCfem\par \\
+              \PRISMDOCsname\par & \PRISMDOCsphone\par & \PRISMDOCsaff\par & \par \\
+              \hline
+            \end{tabular}
+            }}}
+
+     \PRISMDOCDebugBox{\put(0,-0.5){\dashbox{0.1}(15,4.0)[b]{}}}
+      \put(0,-0.5){\makebox(15,4.0)[b]{
+          \parbox{15cm}{
+            \renewcommand{\arraystretch}{1.10}
+            \PRISMDOCFont{T1}{ptm}{m}{n}{9.8pt}{11pt}
+            }}}
+      } % IsItaIB
+    \end{picture}
+    \newpage
+    \pagenumbering{roman}
+    \setcounter{page}{1}
+    \ifthenelse{\boolean{OptTitleonly}}{}%
+    {
+      {
+        \parskip=0pt
+        \tableofcontents
+        \ifthenelse{\boolean{OptFigureList}}{
+          \cleardoublepage
+          \listoffigures
+          }{}
+        \ifthenelse{\boolean{OptTableList}}{
+          \cleardoublepage
+          \listoftables
+          }{}
+        \ifthenelse{\boolean{OptExampleList}}{
+          \cleardoublepage
+          \listof{Example_int}{List of Examples}
+          }{}
+        \ifthenelse{\boolean{OptProgramList}}{
+          \cleardoublepage
+          \listof{Program_int}{List of Programs}
+          }{}
+        \ifthenelse{\boolean{OptJobList}}{
+          \cleardoublepage
+          \listof{Job_int}{List of Jobs}
+          }{}
+        }
+      \cleardoublepage
+      \ifthenelse{\not\boolean{OptNoArabic}}{
+        \pagenumbering{arabic}
+      }{}
+      \cleardoublepage
+      }
+    }
+}{}
+
+
+\newcommand{\Indextt}[1]{\index{#1@\texttt{#1}}}
+\newlength{\PRISMDOCFrameskip}
+\setlength{\PRISMDOCFrameskip}{3pt}
+\newsavebox{\ffbox}
+\newlength{\ffboxl}
+\newenvironment{Frame}[1][\linewidth]{ %
+\begin{lrbox}{\ffbox}
+  \setlength{\ffboxl}{#1}
+  \addtolength{\ffboxl}{-4\fboxrule}
+  \addtolength{\ffboxl}{-4\fboxsep}
+  \begin{minipage}[t]{\ffboxl}
+}                                    %
+{                                    %
+  \end{minipage}
+\end{lrbox}
+\ifthenelse{\boolean{hmode}}{
+  \hskip\parfillskip\\[\PRISMDOCFrameskip]
+}{\vspace{\PRISMDOCFrameskip}}
+\noindent\fbox{\usebox{\ffbox}\\}%
+\vspace{\PRISMDOCFrameskip}%
+}%
+\newcommand{\Mail}[1]{\textbf{#1}}
+\newcommand{\Internet}[1]{\textbf{\texttt{#1}}}
+\newcommand{\Url}[1]{\textbf{\texttt{#1}}}
+\newcommand{\Ftp}[1]{\textbf{\texttt{#1}}}
+\newcommand{\Unixcmd}[1]{\textbf{\texttt{#1}}}
+\newcommand{\Unixopt}[1]{\textbf{\texttt{#1}}}
+\newcommand{\Varunixopt}[1]{\textbf{\texttt{\textit{#1}}}}
+\newcommand{\Shellvar}[1]{\textbf{\texttt{\$#1}}}
+\newcommand{\Path}[1]{\textbf{\texttt{#1}}}
+\newcommand{\File}[1]{\texttt{#1}}
+\newcommand{\Varfile}[1]{\texttt{\textit{#1}}}
+\newcommand{\Prompt}[1]{\texttt{#1}}
+\newcommand{\Unixmessage}[1]{\texttt{#1}}
+\newcommand{\Queue}[1]{\texttt{\textbf{#1}}}
+\newcommand{\Keyword}[1]{\texttt{#1}}
+\newcommand{\Keybrd}[1]{\fbox{\texttt{#1}}}
+%\newcommand{\Tki}[1]{\htmladdnormallink{TKI-#1}%
+%  {http://prism.enes.org}}
+\newenvironment{Indent}{ %
+\begin{list}{}{\topsep=0pt}\item[]
+}%
+{%
+\end{list}
+}
+\newcommand{\Myindent}{\hspace*{\leftmargin}}
+\newcommand{\Crayfilesrv}{\/Cray file server\/}
+\newcommand{\Crayfs}{\/Cray file server\/}
+\newcommand{\Craycs}{\/CRAY J90\/}
+\newcommand{\Craympp}{\/CRAY T3E\/}
+\newcommand{\Craypvp}{\/CRAY T90\/}
+\newcommand{\CrayfilesrvT}{Cray file server}
+\newcommand{\CrayfsT}{Cray file server}
+\newcommand{\CraycsT}{CRAY J90}
+\newcommand{\CraymppT}{CRAY T3E}
+\newcommand{\CraypvpT}{CRAY T90}
+\newcommand{\Jump}{\/Jump\/}
+\newcommand{\Homechar}{$\sim$}
+\newcommand{\Backslash}{$\backslash$}
+\newcommand{\Kea}{[}
+\newcommand{\Kez}{]}
+\newcommand\fs@Boxed{\def\@fs@cfont{\bfseries}\let\@fs@capt\floatc@plain
+  \def\@fs@pre{
+    \setbox\@currbox\vbox{%
+      \hbadness10000%
+      \vbox{%
+        \hrule%
+        \hbox to\hsize{%
+          \vrule\kern2pt%
+          \vbox{%
+            \kern5pt\box\@currbox\kern5pt%
+            }%
+          \kern-2.7pt\vrule}\hrule}%
+      }%
+    }%
+  \def\@fs@mid{\kern3pt}%
+  \def\@fs@post{}\let\@fs@iftopcapt\iffalse}
+\floatstyle{Boxed}
+\setlength{\floatsep}{6pt plus 2pt minus2pt}
+\setlength{\textfloatsep}{10pt plus 2pt minus2pt}
+\setlength{\intextsep}{6pt plus 2pt minus2pt}
+\setlength{\abovecaptionskip}{3pt}
+
+\ifthenelse{\boolean{IsItaRS}}{
+  \newfloat{Program_int}{htbp}{lop}[chapter]
+  \newfloat{Job_int}{htbp}{loj}[chapter]
+  \newfloat{Example_int}{htbp}{loe}[chapter]
+}{
+  \newfloat{Program_int}{htbp}{lop}
+  \newfloat{Job_int}{htbp}{loj}
+  \newfloat{Example_int}{htbp}{loe}
+}
+\floatname{Example_int}{Example}
+\floatname{Program_int}{Program}
+\floatname{Job_int}{Job}
+\ifthenelse{\boolean{OptOldFloat}}
+{%
+  \newenvironment{Example}%
+  {\begin{Example_int}[H]\small\begin{alltt}}%
+  {\end{alltt}\vspace*{-2ex}\end{Example_int}}%
+  \newenvironment{Longexample}%
+  {\begin{Example_int}\small}%
+  {\end{Example_int}}%
+  %
+  \newenvironment{Job}%
+  {\begin{Job_int}[H]\small\begin{alltt}}%
+  {\end{alltt}\vspace*{-2ex}\end{Job_int}}
+  \newenvironment{Longjob}%
+  {\begin{Job_int}\small}%
+  {\end{Job_int}}%
+  \newenvironment{Program}%
+  {\begin{Program_int}[H]\small\begin{alltt}}%
+  {\end{alltt}\vspace*{-2ex}\end{Program_int}}%
+  \newenvironment{Longprogram}%
+  {\begin{Program_int}\small}%
+  {\end{Program_int}}%
+}{ %else
+  \newenvironment{Shortexample}%
+  {\begin{Frame}\small\begin{alltt}}%
+  {\end{alltt}\end{Frame}}%
+  \newenvironment{Example}[1][htbp]%
+  {\begin{Example_int}[#1]\small}%
+  {\end{Example_int}}%
+  %
+  \newenvironment{Shortjob}%
+  {\begin{Frame}\small\begin{alltt}}%
+  {\end{alltt}\end{Frame}}
+  \newenvironment{Job}[1][htbp]%
+  {\begin{Job_int}[#1]\small}%
+  {\end{Job_int}}%
+  \newenvironment{Shortprogram}%
+  {\begin{Frame}\small\begin{alltt}}%
+  {\end{alltt}\end{Frame}}%
+  \newenvironment{Program}[1][htbp]%
+  {\begin{Program_int}[#1]\small}%
+  {\end{Program_int}}%
+}
+\ifthenelse{\boolean{IsItaRS}}
+{%
+  \floatstyle{Boxed}
+% Comment line below if you dont want a frome around the figures
+  \restylefloat{figure}
+}{}
+\newenvironment{Itemize*}%
+{ \partopsep=0pt%
+  \begin{itemize}%
+    \vspace*{-\topsep}%
+    \parskip=0pt\itemsep=0pt\partopsep=0pt%%
+}%
+{%
+  \vspace*{-\topsep}%
+\end{itemize}%
+}
+\newenvironment{Enumerate*}%
+{ \partopsep=0pt%
+  \begin{enumerate}%
+    \vspace*{-\topsep}%
+    \parskip=0pt\itemsep=0pt\partopsep=0pt%%
+}%
+{%
+  \vspace*{-\topsep}%
+\end{enumerate}%
+}
+\newcommand{\longpage}%
+{\enlargethispage{\baselineskip}\PRISMDOCDebugBox{\marginpar{\fbox{+}}}}
+\newcommand{\shortpage}%
+{\enlargethispage{-\baselineskip}\PRISMDOCDebugBox{\marginpar{\fbox{-}}}}
+
+\ifthenelse{\boolean{OptLow}}%
+{%
+\newenvironment{itemize*}%
+{\begin{Itemize*}}%
+{\end{Itemize*}}
+\newenvironment{enumerate*}%
+{\begin{Enumerate*}}%
+{\end{Enumerate*}}
+}{}
+\AtEndDocument{
+
+  \ifthenelse{\boolean{OptIndex}}%
+  {%
+    \appendix
+    \addcontentsline{toc}{chapter}{Index}
+    {\small
+      \printindex
+      }
+    }{}
+    % Katalog
+  \ifthenelse{\boolean{IsItaRS} \and \not \boolean{IsItaIB} \and \not \boolean{IsItaZHB}}%
+  {%
+    \ifthenelse{\boolean{OptTitleonly}}
+    {}{%
+      \cleardoublepage%
+      \pagestyle{empty}%
+     % \input{./styles/bhb-katalog.tex}%
+      }%
+    }{}%
+  }%
+
+\endinput
+%%
+%% End of file `prismdoc.cls'.
Index: CPL/oasis3/trunk/src/mod/oasis3/src/Makefile
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/Makefile	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/Makefile	(revision 1677)
@@ -0,0 +1,228 @@
+
+# This file is generated automatically
+SRCS1 =	$(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.F90' -print)
+OBJS1 =	$(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.F90,  %.o, $(SRCS1))
+
+SRCS2 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.f90' -print)
+OBJS2 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.f90, %.o, $(SRCS2))
+
+SRCS3 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.F' -print)
+OBJS3 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.F, %.o, $(SRCS3))
+
+SRCS4 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.f' -print)
+OBJS4 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.f, %.o, $(SRCS4))
+
+SRCS5 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.c' -print)
+OBJS5 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.c, %.o, $(SRCS5))
+
+VPATH = .:../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)):\
+	  ../../../../src/mod/$(MODEL_DIR)/include:\
+	  ../../lib/clim.${CHAN}:\
+	  ../../../lib/$(MODEL_DIR):\
+	  ../../../lib:\
+	  $(NETCDF_INCLUDE):$(MPI_INCLUDE):$(SYS_INCLUDE):\
+	  ../../../../src/mod/$(MODEL_DIR)/make_dummies
+
+LIBRARY	= ../../../lib/$(MODEL_DIR)/lib$(MODLIB).a
+
+PROG =  ../../../bin/$(EXEC).x
+
+INCLS   = -I../../../../src/mod/$(MODEL_DIR)/include \
+	  -${I4mods}../../lib/clim.${CHAN}
+
+INCLSC  = -I../../../../src/mod/$(MODEL_DIR)/include
+
+clean:
+	rm -f $(LIBRARY)
+	rm -f i.* *.o *.mod
+	rm -f Top_Makefile_*
+
+all: $(PROG)
+
+lib: $(LIBRARY)
+
+$(PROG): $(DEPLIBS) $(LIBRARY)
+	$(F90) $(LDFLAGS) -o $@ $(MAINPRG).o $(LIBS) $(LIBS)
+
+$(LIBRARY): $(OBJS1) $(OBJS2) $(OBJS3) $(OBJS4) $(OBJS5)
+	$(AR) $(ARFLAGS) $(LIBRARY) *.o
+	$(AR) $(ARFLAGS) $(LIBRARY) \
+	../../lib/clim.${CHAN}/mod_kinds_oasis.o   \
+	../../lib/clim.${CHAN}/mod_parameter.o  \
+	../../lib/clim.${CHAN}/mod_timestep.o  \
+	../../lib/clim.${CHAN}/mod_string.o  \
+	../../lib/clim.${CHAN}/mod_unitncdf.o  \
+	../../lib/clim.${CHAN}/mod_kinds_oasis.o  \
+	../../lib/clim.${CHAN}/mod_hardware.o  \
+	../../lib/clim.${CHAN}/mod_calendar.o  \
+	../../lib/clim.${CHAN}/mod_label.o
+
+.SUFFIXES:
+.SUFFIXES: .o .c .f .F .f90 .F90
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# All dependencies ...
+#
+
+mod_anais.o: mod_kinds_oasis.o mod_parameter.o
+mod_analysis.o: mod_kinds_oasis.o
+mod_calendar.o: mod_kinds_oasis.o
+mod_coast.o: mod_kinds_oasis.o
+mod_experiment.o: mod_kinds_oasis.o
+mod_extrapol.o: mod_kinds_oasis.o mod_parameter.o
+mod_gauss.o: mod_kinds_oasis.o
+mod_hardware.o: mod_kinds_oasis.o
+mod_memory.o: mod_kinds_oasis.o mod_parameter.o
+mod_nproc.o: mod_kinds_oasis.o
+mod_parallel.o: mod_kinds_oasis.o
+mod_parameter.o: mod_kinds_oasis.o
+mod_printing.o: mod_kinds_oasis.o
+mod_rainbow.o: mod_kinds_oasis.o mod_parameter.o
+mod_sipc.o: mod_kinds_oasis.o
+mod_smooth.o: mod_kinds_oasis.o
+mod_string.o: mod_kinds_oasis.o
+mod_timestep.o: mod_kinds_oasis.o
+mod_unit.o: mod_kinds_oasis.o
+mod_unitncdf.o: mod_kinds_oasis.o
+alloc.o: mod_parameter.o
+alloc_src.o: mod_anais.o mod_analysis.o mod_coast.o mod_experiment.o \
+	mod_extrapol.o mod_kinds_oasis.o mod_memory.o mod_nproc.o \
+	mod_parallel.o mod_parameter.o mod_pipe.o mod_rainbow.o mod_sipc.o \
+	mod_string.o mod_timestep.o mod_unitncdf.o
+dealloc.o: mod_parameter.o
+dealloc_src.o: mod_anais.o mod_analysis.o mod_coast.o mod_experiment.o \
+	mod_extrapol.o mod_kinds_oasis.o mod_memory.o mod_nproc.o \
+	mod_parallel.o mod_parameter.o mod_pipe.o mod_rainbow.o mod_sipc.o \
+	mod_string.o mod_timestep.o mod_unitncdf.o
+parse.o: mod_kinds_oasis.o mod_unit.o
+parseblk.o: mod_kinds_oasis.o mod_unit.o
+skip.o: mod_kinds_oasis.o mod_unit.o
+chksgc.o: mod_hardware.o mod_printing.o mod_unit.o
+extrap.o: mod_extrapol.o mod_kinds_oasis.o mod_parameter.o mod_printing.o \
+	mod_unit.o
+ferror.o: mod_experiment.o mod_hardware.o mod_kinds_oasis.o mod_nproc.o \
+	mod_parameter.o mod_unit.o
+getfld.o: mod_analysis.o mod_clim.o mod_experiment.o mod_hardware.o \
+	mod_kinds_oasis.o mod_label.o mod_memory.o mod_parameter.o \
+	mod_printing.o mod_sipc.o mod_string.o mod_timestep.o mod_unit.o \
+	mod_unitncdf.o netcdf.inc
+givfld.o: mod_analysis.o mod_calendar.o mod_clim.o mod_experiment.o \
+	mod_hardware.o mod_kinds_oasis.o mod_label.o mod_memory.o \
+	mod_parameter.o mod_printing.o mod_sipc.o mod_string.o mod_timestep.o \
+	mod_unit.o mod_unitncdf.o netcdf.inc
+halte.o: mod_comclim.o mod_hardware.o mod_unit.o
+inicmc.o: mod_analysis.o mod_clim.o mod_clim_def.o mod_comclim.o \
+	mod_experiment.o mod_gauss.o mod_hardware.o mod_kinds_oasis.o \
+	mod_label.o mod_parallel.o mod_parameter.o mod_printing.o \
+	mod_string.o mod_timestep.o mod_unit.o mod_unitncdf.o
+iniiof.o: mod_anais.o mod_analysis.o mod_extrapol.o mod_hardware.o \
+	mod_label.o mod_parameter.o mod_printing.o mod_string.o mod_unit.o \
+	mod_unitncdf.o netcdf.inc
+inipar.o: mod_anais.o mod_analysis.o mod_calendar.o mod_clim.o mod_coast.o \
+	mod_experiment.o mod_extrapol.o mod_hardware.o mod_kinds_oasis.o \
+	mod_label.o mod_parallel.o mod_parameter.o mod_printing.o \
+	mod_rainbow.o mod_string.o mod_timestep.o mod_unit.o mod_unitncdf.o \
+	netcdf.inc
+inipar_alloc.o: mod_anais.o mod_analysis.o mod_calendar.o mod_clim.o \
+	mod_coast.o mod_experiment.o mod_extrapol.o mod_gauss.o \
+	mod_hardware.o mod_kinds_oasis.o mod_label.o mod_parallel.o \
+	mod_parameter.o mod_printing.o mod_rainbow.o mod_string.o \
+	mod_timestep.o mod_unit.o mod_unitncdf.o netcdf.inc
+modsgc.o: mod_hardware.o mod_printing.o mod_unit.o
+preproc.o: mod_analysis.o mod_extrapol.o mod_gauss.o mod_kinds_oasis.o \
+	mod_label.o mod_memory.o mod_parameter.o mod_printing.o mod_string.o \
+	mod_unit.o
+waitpc.o: mod_clim.o mod_experiment.o mod_hardware.o mod_kinds_oasis.o \
+	mod_nproc.o mod_parameter.o mod_pipe.o mod_printing.o mod_sipc.o \
+	mod_unit.o
+blasnew.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+blasold.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+calend.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+chkfld.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+chkpar.o: mod_experiment.o mod_extrapol.o mod_hardware.o mod_kinds_oasis.o \
+	mod_parameter.o mod_printing.o mod_string.o mod_timestep.o mod_unit.o
+coasts.o: mod_coast.o mod_kinds_oasis.o mod_parameter.o mod_printing.o \
+	mod_smooth.o mod_unit.o
+conserv.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+cookart.o: mod_analysis.o mod_kinds_oasis.o mod_memory.o mod_parameter.o \
+	mod_printing.o mod_rainbow.o mod_string.o mod_unit.o
+correct.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+couple.o: mod_unit.o
+driver.o: mod_analysis.o mod_experiment.o mod_hardware.o mod_kinds_oasis.o \
+	mod_memory.o mod_parameter.o mod_string.o mod_timestep.o mod_unit.o
+empty.o: mod_unit.o
+extraw.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+fiasco.o: mod_anais.o mod_intbi.o mod_intlin.o mod_kinds_oasis.o \
+	mod_parameter.o mod_printing.o mod_timestep.o mod_unit.o
+filling.o: mod_analysis.o mod_calendar.o mod_coast.o mod_kinds_oasis.o \
+	mod_parameter.o mod_printing.o mod_smooth.o mod_unit.o
+getfpe.o: mod_unit.o
+glored.o: mod_gauss.o mod_kinds_oasis.o mod_printing.o mod_unit.o
+grstat.o: mod_kinds_oasis.o mod_unit.o
+hdlerr.o: mod_kinds_oasis.o mod_unit.o netcdf.inc
+icoor.o: mod_kinds_oasis.o mod_unit.o
+idivmax.o: mod_kinds_oasis.o mod_unit.o
+ilenstr.o: mod_unit.o
+imaxim.o: mod_kinds_oasis.o mod_unit.o
+iminim.o: mod_kinds_oasis.o mod_unit.o
+inidya.o: mod_kinds_oasis.o mod_memory.o mod_parameter.o mod_printing.o \
+	mod_string.o mod_unit.o
+inigrd.o: mod_analysis.o mod_kinds_oasis.o mod_label.o mod_memory.o \
+	mod_parameter.o mod_printing.o mod_string.o mod_unit.o mod_unitncdf.o \
+	netcdf.inc
+inilun.o: mod_hardware.o mod_parameter.o mod_printing.o mod_string.o \
+	mod_unit.o
+initim.o: mod_calendar.o mod_parameter.o mod_printing.o mod_string.o \
+	mod_timestep.o mod_unit.o
+interp.o: mod_anais.o mod_analysis.o mod_extrapol.o mod_kinds_oasis.o \
+	mod_memory.o mod_parameter.o mod_printing.o mod_rainbow.o \
+	mod_string.o mod_unit.o
+invert.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+isumi.o: mod_kinds_oasis.o mod_unit.o
+izero.o: mod_kinds_oasis.o mod_unit.o
+jcoor.o: mod_kinds_oasis.o mod_unit.o
+locread.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+locreadh.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+locrint.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+locwrint.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+locwrite.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+locwrith.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+masq.o: mod_hardware.o mod_kinds_oasis.o mod_printing.o mod_unit.o
+mod_intbi.o: mod_bicub.o mod_findpos.o mod_unit.o
+mod_intlin.o: mod_bilin.o mod_findlin.o mod_unit.o
+mozaic.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+nextbl.o: mod_unit.o
+nextch.o: mod_unit.o
+postpro.o: mod_analysis.o mod_extrapol.o mod_gauss.o mod_kinds_oasis.o \
+	mod_label.o mod_memory.o mod_parameter.o mod_printing.o mod_string.o \
+	mod_unit.o
+prcout.o: mod_unit.o
+prtout.o: mod_kinds_oasis.o mod_unit.o
+redglo.o: mod_gauss.o mod_kinds_oasis.o mod_label.o mod_parameter.o \
+	mod_printing.o mod_unit.o mod_unitncdf.o netcdf.inc
+reset.o: mod_memory.o mod_parameter.o mod_printing.o mod_unit.o
+reverse.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+revmsk.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+rmaxim.o: mod_kinds_oasis.o mod_unit.o
+rminim.o: mod_kinds_oasis.o mod_unit.o
+sqdis.o: mod_kinds_oasis.o mod_unit.o
+ssumr.o: mod_kinds_oasis.o mod_unit.o
+subgrid.o: mod_kinds_oasis.o mod_printing.o mod_unit.o
+szero.o: mod_kinds_oasis.o mod_unit.o
+updtim.o: mod_calendar.o mod_kinds_oasis.o mod_parameter.o mod_printing.o \
+	mod_timestep.o mod_unit.o
Index: CPL/oasis3/trunk/src/mod/oasis3/src/Makefile_1
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/Makefile_1	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/Makefile_1	(revision 1677)
@@ -0,0 +1,79 @@
+SRCS1 =	$(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.F90' -print)
+OBJS1 =	$(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.F90,  %.o, $(SRCS1))
+
+SRCS2 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.f90' -print)
+OBJS2 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.f90, %.o, $(SRCS2))
+
+SRCS3 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.F' -print)
+OBJS3 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.F, %.o, $(SRCS3))
+
+SRCS4 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.f' -print)
+OBJS4 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.f, %.o, $(SRCS4))
+
+SRCS5 =  $(shell find ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)) -name '*.c' -print)
+OBJS5 =  $(patsubst ../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC))/%.c, %.o, $(SRCS5))
+
+VPATH = .:../../../../src/mod/$(MODEL_DIR)/$(strip $(SRC)):\
+	  ../../../../src/mod/$(MODEL_DIR)/include:\
+	  ../../lib/clim.${CHAN}:\
+	  ../../../lib/$(MODEL_DIR):\
+	  ../../../lib:\
+	  $(NETCDF_INCLUDE):$(MPI_INCLUDE):$(SYS_INCLUDE):\
+	  ../../../../src/mod/$(MODEL_DIR)/make_dummies
+
+LIBRARY	= ../../../lib/$(MODEL_DIR)/lib$(MODLIB).a
+
+PROG =  ../../../bin/$(EXEC).x
+
+INCLS   = -I../../../../src/mod/$(MODEL_DIR)/include \
+	  -${I4mods}../../lib/clim.${CHAN}
+
+INCLSC  = -I../../../../src/mod/$(MODEL_DIR)/include
+
+clean:
+	rm -f $(LIBRARY)
+	rm -f i.* *.o *.mod
+	rm -f Top_Makefile_*
+
+all: $(PROG)
+
+lib: $(LIBRARY)
+
+$(PROG): $(DEPLIBS) $(LIBRARY)
+	$(F90) $(LDFLAGS) -o $@ $(MAINPRG).o $(LIBS) $(LIBS)
+
+$(LIBRARY): $(OBJS1) $(OBJS2) $(OBJS3) $(OBJS4) $(OBJS5)
+	$(AR) $(ARFLAGS) $(LIBRARY) *.o
+	$(AR) $(ARFLAGS) $(LIBRARY) \
+	../../lib/clim.${CHAN}/mod_kinds_oasis.o   \
+	../../lib/clim.${CHAN}/mod_parameter.o  \
+	../../lib/clim.${CHAN}/mod_timestep.o  \
+	../../lib/clim.${CHAN}/mod_string.o  \
+	../../lib/clim.${CHAN}/mod_unitncdf.o  \
+	../../lib/clim.${CHAN}/mod_kinds_oasis.o  \
+	../../lib/clim.${CHAN}/mod_hardware.o  \
+	../../lib/clim.${CHAN}/mod_calendar.o  \
+	../../lib/clim.${CHAN}/mod_label.o
+
+.SUFFIXES:
+.SUFFIXES: .o .c .f .F .f90 .F90
+
+%.o: %.F90
+	$(F90) $(F90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.f90
+	$(f90) $(f90FLAGS) $(INCLS)  -c   $<
+
+%.o: %.F
+	$(F) $(FFLAGS) $(INCLS)  -c   $<
+
+%.o: %.f
+	$(f) $(fFLAGS) $(INCLS)  -c   $<
+
+%.o: %.c
+	$(CC) $(CCFLAGS) $(INCLSC) -c   $<
+
+#
+# All dependencies ...
+#
+# Dont add anything behind this line
Index: CPL/oasis3/trunk/src/mod/oasis3/src/alloc.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/alloc.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/alloc.f90	(revision 1677)
@@ -0,0 +1,133 @@
+SUBROUTINE alloc (id_flag)
+!
+!
+!**** INIALLOC
+!
+!     Purpose:
+!       Allocate arrays defined in the modules
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_parameter
+!
+!* ---------------------------- Local declarations ----------------------
+!
+     INTEGER (kind=ip_intwp_p) :: id_flag
+!
+!*-----------------------------------------------------------------------
+!
+IF (id_flag .EQ. 1) THEN
+!** + Module mod_experiment
+!
+  CALL alloc_experiment
+!
+!** + Module mod_string
+!
+  CALL alloc_string
+!
+!** + Following routines will be called only if one field (at least) goes
+!     through Oasis  
+!
+  IF (lg_oasis_field) THEN 
+!
+!** + Module mod_anais
+!
+     CALL alloc_anais1
+!
+!** + Module mod_analysis
+!
+     CALL alloc_analysis
+!
+!** + Module mod_coast
+!
+     CALL alloc_coast
+!
+!** + Module mod_extrapol
+!
+     CALL alloc_extrapol1 
+!
+!** + Module mod_memory
+!
+     CALL alloc_memory1
+!
+!** + Module mod_nproc
+!
+     CALL alloc_nproc
+!
+!** + Module mod_parallel
+!
+     CALL alloc_parallel
+!
+!** + Module mod_pipe
+!
+     CALL alloc_pipe
+!
+!** + Module mod_rainbow
+!
+     CALL alloc_rainbow1
+!
+!** + Module mod_sipc
+!
+     CALL alloc_sipc
+!
+!** + Module mod_timestep
+!
+     CALL alloc_timestep
+!
+!** + Module mod_unitncdf
+!
+     CALL alloc_unitncdf
+!
+  ENDIF
+ELSE
+  IF (lg_oasis_field) THEN 
+!
+!** + Module mod_anais
+!
+     CALL alloc_anais2
+!
+!** + Module mod_extrapol
+!
+     CALL alloc_extrapol2 
+!
+!** + Module mod_memory
+!
+     CALL alloc_memory2
+!
+!** + Module mod_rainbow
+!
+     CALL alloc_rainbow2
+!
+   ENDIF
+ENDIF
+!*------------------------------------------------------------------------
+!
+END SUBROUTINE alloc
+!
+!*========================================================================
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/alloc_src.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/alloc_src.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/alloc_src.f90	(revision 1677)
@@ -0,0 +1,1463 @@
+!                       ***************************
+!                       *  ALLOCATION SUBROUTINES *
+!                       ***************************
+SUBROUTINE alloc_anais1
+!
+!**** ALLOC_ANAIS
+!
+!     Purpose:
+!       Allocate arrays defined in the "anais" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_anais
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (varmul(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "varmul"allocation of anais module',il_err,1)
+  varmul(:)=0
+  ALLOCATE (niwtm(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "niwtm"allocation of anais module',il_err,1)
+  niwtm(:)=0
+  ALLOCATE (niwtg(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "niwtg"allocation of anais module',il_err,1)
+  niwtg(:)=0
+  ALLOCATE (linit(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "linit"allocation of anais module',il_err,1)
+  linit(:)=.false.
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_anais1
+!
+!*========================================================================
+!
+SUBROUTINE alloc_anais2
+!
+!**** ALLOC_ANAIS
+!
+!     Purpose:
+!       Allocate arrays defined in the "anais" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       3.0       S. Valcke       2004/01/05  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_anais
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (ngint(ig_maxnoa*ig_maxnfg*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ngint"allocation of anais module',il_err,1)
+  ngint(:)=0
+  ALLOCATE (nmint(ig_maxwoa*ig_maxnfm*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nmint"allocation of anais module',il_err,1)
+  nmint(:)=0
+  ALLOCATE (nmesh(ig_maxnfm*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nmesh"allocation of anais module',il_err,1)
+  nmesh(:)=0
+  ALLOCATE (agint(ig_maxnoa*ig_maxnfg*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "agint"allocation of anais module',il_err,1)
+  agint(:)=0
+  ALLOCATE (amint(ig_maxwoa*ig_maxnfm*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "amint"allocation of anais module',il_err,1)
+  amint(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_anais2
+!
+!*========================================================================
+SUBROUTINE alloc_analysis
+!
+!**** ALLOC_ANALYSIS
+!
+!     Purpose:
+!       Allocate arrays defined in the "analysis" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_analysis
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (ncofld(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ncofld"allocation of analysis module',il_err,1)
+  ncofld(:)=0
+  ALLOCATE (neighborg(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "neighborg"allocation of analysis module',il_err,1)
+  neighborg(:)=0
+  ALLOCATE (nludat(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nludat"allocation of analysis module',il_err,1)
+  nludat(:,:)=0
+  ALLOCATE (nlufil(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nlufil"allocation of analysis module',il_err,1)
+  nlufil(:)=0
+  ALLOCATE (nlumap(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nlumap"allocation of analysis module',il_err,1)
+  nlumap(:)=0
+  ALLOCATE (nlusub(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nlusub"allocation of analysis module',il_err,1)
+  nlusub(:)=0
+  ALLOCATE (nluext(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nluext"allocation of analysis module',il_err,1)
+  nluext(:)=0
+  ALLOCATE (nosper(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nosper"allocation of analysis module',il_err,1)
+  nosper(:)=0
+  ALLOCATE (notper(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "notper"allocation of analysis module',il_err,1)
+  notper(:)=0
+  ALLOCATE (ntinpflx(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ntinpflx"allocation of analysis module',il_err,1)
+  ntinpflx(:)=0
+  ALLOCATE (ntoutflx(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ntoutflx"allocation of analysis module',il_err,1)
+  ntoutflx(:)=0
+  ALLOCATE (amskval(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "amskval"allocation of analysis module',il_err,1)
+  amskval(:)=0
+  ALLOCATE (amskvalnew(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "amskvalnew"allocation of analysis module',il_err,1)
+  amskvalnew(:)=0
+  ALLOCATE (acocoef(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "acocoef"allocation of analysis module',il_err,1)
+  acocoef(:,:)=0
+  ALLOCATE (abocoef(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "abocoef"allocation of analysis module',il_err,1)
+  abocoef(:,:)=0
+  ALLOCATE (abncoef(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "abncoef"allocation of analysis module',il_err,1)
+  abncoef(:,:)=0
+  ALLOCATE (afldcoef(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "afldcoef"allocation of analysis module',il_err,1)
+  afldcoef(:)=0
+  ALLOCATE (afldcobo(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "afldcobo"allocation of analysis module',il_err,1)
+  afldcobo(:)=0
+  ALLOCATE (afldcobn(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "afldcobn"allocation of analysis module',il_err,1)
+  afldcobn(:)=0
+  ALLOCATE (cxordbf(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cxordbf"allocation of analysis module',il_err,1)
+  cxordbf(:)=' '
+  ALLOCATE (cyordbf(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cyordbf"allocation of analysis module',il_err,1)
+  cyordbf(:)=' '
+  ALLOCATE (cxordaf(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cxordaf"allocation of analysis module',il_err,1)
+  cxordaf(:)=' '
+  ALLOCATE (cyordaf(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cyordaf"allocation of analysis module',il_err,1)
+  cyordaf(:)=' '
+  ALLOCATE (cgrdtyp(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cgrdtyp"allocation of analysis module',il_err,1)
+  cgrdtyp(:)=' '
+  ALLOCATE (cfldtyp(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfldtyp"allocation of analysis module',il_err,1)
+  cfldtyp(:)=' '
+  ALLOCATE (cfilfic(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfilfic"allocation of analysis module',il_err,1)
+  cfilfic(:)=' '
+  ALLOCATE (cfilmet(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfilmet"allocation of analysis module',il_err,1)
+  cfilmet(:)=' '
+  ALLOCATE (cconmet(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cconmet"allocation of analysis module',il_err,1)
+  cconmet(:)=' '
+  ALLOCATE (cfldcoa(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfldcoa"allocation of analysis module',il_err,1)
+  cfldcoa(:)=' '
+  ALLOCATE (cfldfin(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfldfin"allocation of analysis module',il_err,1)
+  cfldfin(:)=' '
+  ALLOCATE (ccofld(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ccofld"allocation of analysis module',il_err,1)
+  ccofld(:,:)=' '
+  ALLOCATE (cbofld(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cbofld"allocation of analysis module',il_err,1)
+  cbofld(:,:)=' '
+  ALLOCATE (cbnfld(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "cbnfld"allocation of analysis module',il_err,1)
+  cbnfld(:,:)=' '
+  ALLOCATE (ccofic(ig_maxcomb,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ccofic"allocation of analysis module',il_err,1)
+  ccofic(:,:)=' '
+  ALLOCATE (cdqdt(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cdqdt"allocation of analysis module',il_err,1)
+  cdqdt(:)=' '
+  ALLOCATE (cgrdmap(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cgrdmap"allocation of analysis module',il_err,1)
+  cgrdmap(:)=' '
+  ALLOCATE (cmskrd(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cmskrd"allocation of analysis module',il_err,1)
+  cmskrd(:)=' '
+  ALLOCATE (cgrdsub(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cgrdsub"allocation of analysis module',il_err,1)
+  cgrdsub(:)=' '
+  ALLOCATE (ctypsub(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ctypsub"allocation of analysis module',il_err,1)
+  ctypsub(:)=' '
+  ALLOCATE (cgrdext(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "cgrdext"allocation of analysis module',il_err,1)
+  cgrdext(:)=' '
+  ALLOCATE (csper(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "csper"allocation of analysis module',il_err,1)
+  csper(:)=' '
+  ALLOCATE (ctper(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ctper"allocation of analysis module',il_err,1)
+  ctper(:)=' '
+  ALLOCATE (lsurf(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lsurf"allocation of analysis module',il_err,1)
+  lsurf(:)=.false.
+  ALLOCATE (nscripvoi(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in nscripvoi allocation of analysis module',il_err,1)
+  nscripvoi(:)=0
+! 
+!* Alloc array needed for SCRIP 
+!
+  ALLOCATE (cmap_method(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cmap_method" allocation of inipar_alloc',il_err,1)
+  cmap_method(:)=' '
+  ALLOCATE (cfldtype(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cfldtype"allocation of inipar_alloc',il_err,1)
+  cfldtype(:)=' '
+  ALLOCATE (crsttype(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "crsttype"allocation of inipar_alloc',il_err,1)
+  crsttype(:)=' '
+  ALLOCATE (nbins(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "nbins"allocation of inipar_alloc',il_err,1)
+  nbins(:)=0
+  ALLOCATE (cnorm_opt(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "cnorm_opt"allocation of inipar_alloc',il_err,1)
+  cnorm_opt(:)=' '
+  ALLOCATE (corder(ig_nfield),stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "corder"allocation of inipar_alloc',il_err,1)
+  corder(:)=' '
+!
+!Vector case:
+!
+  IF (lg_vector) THEN
+      ALLOCATE (cg_assoc_input_field(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cg_assoc_input_field"allocation of inipar_alloc',il_err,1)
+      cg_assoc_input_field(:)=' '
+      ALLOCATE (ig_assoc_input_field(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_assoc_input_field"allocation of inipar_alloc',il_err,1)
+      ig_assoc_input_field(:)=0
+      ALLOCATE (lrotate(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lrotate"allocation of inipar_alloc',il_err,1)
+  ENDIF
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_analysis
+!
+!*========================================================================
+SUBROUTINE alloc_coast
+!
+!**** ALLOC_COAST
+!
+!     Purpose:
+!       Allocate arrays defined in the "coast" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_coast
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (npcoast(ig_maxwoa,6), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "npcoast"allocation of coast module',il_err,1)
+  npcoast(:,:)=0
+  
+!
+!* ----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_coast
+!
+!*=======================================================================
+SUBROUTINE alloc_experiment
+!
+!**** ALLOC_EXPERIMENT
+!
+!     Purpose:
+!       Allocate arrays defined in the "experiment" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_experiment
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (nbcplproc(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nbcplproc"allocation of experiment module',il_err,1)
+  nbcplproc(:)=0
+  ALLOCATE (nbtotproc(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nbtotproc"allocation of experiment module',il_err,1)
+  nbtotproc(:)=0
+  ALLOCATE (cmodnam(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cmodnam"allocation of experiment module',il_err,1)
+  cmodnam(:)=' '
+  ALLOCATE (cmpiarg(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cmpiarg"allocation of experiment module',il_err,1)
+  cmpiarg(:)=' '
+  ALLOCATE (iga_unitmod(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in iga_unitmod allocation of experiment module',il_err,1)
+  iga_unitmod(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_experiment
+!
+!*========================================================================
+SUBROUTINE alloc_extrapol1
+!
+!**** ALLOC_EXTRAPOL
+!
+!     Purpose:
+!       Allocate arrays defined in the "extrapol" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_extrapol
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (niwtn(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "niwtn"allocation of extrapol module',il_err,1)
+  niwtn(:)=0
+  ALLOCATE (niwtng(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "niwtng"allocation of extrapol module',il_err,1)
+  niwtng(:)=0
+  ALLOCATE (lextra(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lextra"allocation of extrapol module',il_err,1)
+  lextra(:)=.false.
+  ALLOCATE (lweight(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lweight"allocation of extrapol module',il_err,1)
+  lweight(:)=.false.
+  ALLOCATE (lextrapdone(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout &
+     ('Error in "lextrapdone" allocation',il_err,1)
+  lextrapdone(:) = .FALSE.
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_extrapol1
+!
+!*========================================================================
+!
+SUBROUTINE alloc_extrapol2
+!
+!**** ALLOC_EXTRAPOL
+!
+!     Purpose:
+!       Allocate arrays defined in the "extrapol" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       3.0       S. Valcke      2004/01/05  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_extrapol
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (aextra(ig_maxext*ig_maxnbn*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "aextra"allocation of extrapol module',il_err,1)
+  aextra(:)=0
+  ALLOCATE (nextra(ig_maxext*ig_maxnbn*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nextra"allocation of extrapol module',il_err,1)
+  nextra(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_extrapol2
+!
+!*========================================================================
+SUBROUTINE alloc_memory1
+!
+!**** ALLOC_MEMORY
+!
+!     Purpose:
+!       Allocate arrays defined in the "memory" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_memory
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (nsizold(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout &  
+     ('Error in "nsizold"allocation of memory module',il_err,1)
+  nsizold(:)=0
+  ALLOCATE (nsiznew(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nsiznew"allocation of memory module',il_err,1)
+  nsiznew(:)=0
+  ALLOCATE (nadrold(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nadrold"allocation of memory module',il_err,1)
+  nadrold(:)=0
+  ALLOCATE (nadrold_grid(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nadrold_grid"allocation of memory module',il_err,1)
+  nadrold_grid(:)=0
+  ALLOCATE (nadrnew(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nadrnew"allocation of memory module',il_err,1)
+  nadrnew(:)=0
+  ALLOCATE (nadrnew_grid(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nadrnew_grid"allocation of memory module',il_err,1)
+  nadrnew_grid(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_memory1
+!
+!*========================================================================
+SUBROUTINE alloc_memory2
+!
+!**** ALLOC_MEMORY
+!
+!     Purpose:
+!       Allocate arrays defined in the "memory" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       3.0       S. Valcke       2004/01/05  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_memory
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (mskold(ig_maxold_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mskold"allocation of memory module',il_err,1)
+  mskold(:)=0
+  ALLOCATE (msknew(ig_maxnew_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "msknew"allocation of memory module',il_err,1)
+  msknew(:)=0
+  ALLOCATE (fldold(ig_maxold), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "fldold"allocation of memory module',il_err,1)
+  fldold(:)=0
+  ALLOCATE (xgrold(ig_maxold_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "xgrold"allocation of memory module',il_err,1)
+  xgrold(:)=0
+  ALLOCATE (ygrold(ig_maxold_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ygrold"allocation of memory module',il_err,1)
+  ygrold(:)=0
+  ALLOCATE (surold(ig_maxold_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "surold"allocation of memory module',il_err,1)
+  surold(:)=0
+  ALLOCATE (fldnew(ig_maxnew), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "fldnew"allocation of memory module',il_err,1)
+  fldnew(:)=0
+  ALLOCATE (xgrnew(ig_maxnew_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "xgrnew"allocation of memory module',il_err,1)
+  xgrnew(:)=0
+  ALLOCATE (ygrnew(ig_maxnew_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ygrnew"allocation of memory module',il_err,1)
+  ygrnew(:)=0
+  ALLOCATE (surnew(ig_maxnew_grid), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "surnew"allocation of memory module',il_err,1)
+  surnew(:)=0
+  ALLOCATE (nwork(ig_nwork), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nwork"allocation of memory module',il_err,1)
+  nwork(:)=0
+  ALLOCATE (work(ig_work), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "work"allocation of memory module',il_err,1)
+  work(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_memory2
+!
+!*========================================================================
+SUBROUTINE alloc_nproc
+!
+!**** ALLOC_NPROC
+!
+!     Purpose:
+!       Allocate arrays defined in the "nproc" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_nproc
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (nproc(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nproc"allocation of nproc module',il_err,1)
+  nproc(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_nproc
+!
+!*========================================================================
+SUBROUTINE alloc_parallel
+!
+!**** ALLOC_ANALYSIS
+!
+!     Purpose:
+!       Allocate arrays defined in the "parallel" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_parallel
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (nparal(3,ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nparal"allocation of parallel module',il_err,1)
+  nparal(:,:)=0
+  ALLOCATE (cparal(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cparal"allocation of parallel module',il_err,1)
+  cparal(:)=' '  
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_parallel
+!
+!*========================================================================
+SUBROUTINE alloc_pipe
+!
+!**** ALLOC_PIPE
+!
+!     Purpose:
+!       Allocate arrays defined in the "pipe" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_pipe
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (cprnam(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cprnam"allocation of pipe module',il_err,1)
+  cprnam(:)=' '
+  ALLOCATE (cpwnam(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cpwnam"allocation of pipe module',il_err,1)
+  cpwnam(:)=' '
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_pipe
+!
+!*========================================================================
+SUBROUTINE alloc_rainbow1
+!
+!**** ALLOC_RAINBOW
+!
+!     Purpose:
+!       Allocate arrays defined in the "rainbow" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_rainbow
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (lmapp(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lmapp"allocation of rainbow module',il_err,1)
+  lmapp(:)=.false.
+  ALLOCATE (lsubg(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "lsubg"allocation of rainbow module',il_err,1)
+  lsubg(:)=.false.
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_rainbow1
+!
+!*========================================================================
+SUBROUTINE alloc_rainbow2
+!
+!**** ALLOC_RAINBOW
+!
+!     Purpose:
+!       Allocate arrays defined in the "rainbow" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_rainbow
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (amapp(ig_maxmoa*ig_maxnfp*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "amapp"allocation of rainbow module',il_err,1)
+  amapp(:)=0
+  ALLOCATE (asubg(ig_maxsoa*ig_maxnfs*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "asubg"allocation of rainbow module',il_err,1)
+  asubg(:)=0
+  ALLOCATE (nmapp(ig_maxmoa*ig_maxnfp*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nmapp"allocation of rainbow module',il_err,1)
+  nmapp(:)=0
+  ALLOCATE (nsubg(ig_maxsoa*ig_maxnfs*ig_maxgrd), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "asubg"allocation of rainbow module',il_err,1)
+  nsubg(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_rainbow2
+!
+!*========================================================================
+SUBROUTINE alloc_sipc
+!
+!**** ALLOC_SIPC
+!
+!     Purpose:
+!       Allocate arrays defined in the "sipc" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_sipc
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (mpoolidin(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mpoolidin"allocation of sipc module',il_err,1)
+  mpoolidin(:)=0
+  ALLOCATE (mpoolidou(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mpoolidou"allocation of sipc module',il_err,1)
+  mpoolidou(:)=0
+  ALLOCATE (mpoolinitr(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mpoolinitr"allocation of sipc module',il_err,1)
+  mpoolinitr(:)=0
+  ALLOCATE (mpoolinitw(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mpoolinitw"allocation of sipc module',il_err,1)
+  mpoolinitw(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_sipc
+!
+!*========================================================================
+SUBROUTINE alloc_string
+!
+!**** ALLOC_SIPC
+!
+!     Purpose:
+!       Allocate arrays defined in the "string" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_string
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (cg_name_rstfile(ig_nbr_rstfile), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cg_name_rstfile"allocation of string module',il_err,1)
+  cg_name_rstfile(:)=' '
+  ALLOCATE (ig_lag(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_lag"allocation of string module',il_err,1) 
+  ig_lag(:)=0
+  ALLOCATE (ig_no_rstfile(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_no_rstfile"allocation of string module',il_err,1)
+  ig_no_rstfile(:)=1
+  ALLOCATE (cg_input_field(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cg_input_field"allocation of string module',il_err,1)
+  cg_input_field(:)=' '
+  ALLOCATE (ig_numlab(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_numlab"allocation of string module',il_err,1)
+  ig_numlab(:)=0
+  ALLOCATE (ig_freq(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_freq"allocation of string module',il_err,1)
+  ig_freq(:)=0
+  ALLOCATE (ig_total_nseqn(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_total_nseqn"allocation of string module',il_err,1)
+  ig_total_nseqn(:)=0
+  ALLOCATE (ig_local_trans(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_local_trans"allocation of string module',il_err,1)
+  ig_local_trans(:)=0
+  ALLOCATE (ig_invert(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_invert" allocation of string module',il_err,1) 
+  ig_invert(:)=0
+  ALLOCATE (ig_reverse(ig_total_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_reverse" allocation of string module',il_err,1) 
+  ig_reverse(:)=0
+!
+!** + Allocate following arrays only if one field (at least) goes
+!     through Oasis
+!
+  IF (lg_oasis_field) THEN
+  ALLOCATE (numlab(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "numlab"allocation of string module',il_err,1)
+  numlab(:)=0
+  ALLOCATE (nfexch(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nfexch"allocation of string module',il_err,1)
+  nfexch(:)=0
+  ALLOCATE (nluinp(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nluinp"allocation of string module',il_err,1)
+  nluinp(:)=0
+  ALLOCATE (nluout(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nluout"allocation of string module',il_err,1)
+  nluout(:)=0
+  ALLOCATE (nseqn(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nseqn"allocation of string module',il_err,1)
+  nseqn(:)=0
+  ALLOCATE (nlagn(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nlagn" allocation of string module',il_err,1)
+  nlagn(:)=0
+  ALLOCATE (cnaminp(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cnaminp"allocation of string module',il_err,1)
+  cnaminp(:)=' '
+  ALLOCATE (cnamout(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cnamout"allocation of string module',il_err,1)
+  cnamout(:)=' '
+  ALLOCATE (cficout(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cficout"allocation of string module',il_err,1)
+  cficout(:)=' '
+  ALLOCATE (cstate(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "cstate"allocation of string module',il_err,1)
+  cstate(:)=' '
+  ALLOCATE (ig_portin_id(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_portin_id"allocation of string module',il_err,1)
+  ig_portin_id(:)=0
+  ALLOCATE (ig_portout_id(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "ig_portout_id"allocation of string module',il_err,1)
+  ig_portout_id(:)=0
+  ENDIF
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_string
+!
+!*========================================================================
+SUBROUTINE alloc_timestep
+!
+!**** ALLOC_SIPC
+!
+!     Purpose:
+!       Allocate arrays defined in the "timestep" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_timestep
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (mstep(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mstep"allocation of timestep module',il_err,1)
+  mstep(:)=0
+  ALLOCATE (mfcpl(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mfcpl"allocation of timestep module',il_err,1)
+  mfcpl(:)=0
+  ALLOCATE (mdt(ig_nmodel), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "mdt"allocation of timestep module',il_err,1)
+  mdt(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_timestep
+!
+!*========================================================================
+SUBROUTINE alloc_unitncdf
+!
+!**** ALLOC_UNITNCDF
+!
+!     Purpose:
+!       Allocate arrays defined in the "unitncdf" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Uses run parameters read in "inipar_alloc" routine to 
+!       allocate arrays.       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+  USE mod_unitncdf
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  ALLOCATE (nc_inpid(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nc_inpid"allocation of unitncdf module',il_err,1)
+  nc_inpid(:)=0
+  ALLOCATE (nc_outid(ig_nfield), stat=il_err)
+  IF (il_err.NE.0) CALL prtout & 
+     ('Error in "nc_outid"allocation of unitncdf module',il_err,1)
+  nc_outid(:)=0
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE alloc_unitncdf
+!
+!*========================================================================
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/blasnew.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/blasnew.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/blasnew.f	(revision 1677)
@@ -0,0 +1,145 @@
+      SUBROUTINE blasnew (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr,
+     $                    kasize, pacoeff, ksiztot, paux)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *blasnew* - Stupid blas routine
+C
+C     Purpose:
+C     -------
+C     Do linear combination of fields with given coefficients
+C     after interpolation
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *blasnew (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr,
+C                         kasize, pacoeff, ksiztot, paux)*
+C
+C     Input:
+C     -----
+C                pfild   : field array to be modified (real 1D)
+C                kmsize  : size of the field array (integer)
+C                kfield  : field identificator number (integer)
+C                pmcoeff : field multiplicative coefficient (real)
+C                kaux    : number of combined auxilary fields (integer)
+C                kaddr   : pointer for auxilary fields (integer 1D)
+C                kasize  : size of auxilary fields (integer 1D)
+C                pacoeff : auxilary field multiplicative coefficient (real 1D)
+C                ksiztot : total size of work memory used (integer)
+C                paux    : global work array (real 1D)
+C                
+C     Output:
+C     ------
+C                pfild   : new field array (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(kmsize)
+      REAL (kind=ip_realwp_p) paux(ksiztot), pacoeff(kaux)
+      INTEGER (kind=ip_intwp_p) kaddr(0:kaux), kasize(0:kaux)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) istop
+      LOGICAL llchk
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE blasnew  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Do linear combination of fields'
+          WRITE (UNIT = nulou,FMT = *) ' after interpolation '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      istop = 0
+C
+C* Check all auxilary fields have same dimensions as current field
+C
+      DO 110 jc = 1, kaux
+        llchk = (kasize(jc) - kmsize) .EQ. 0
+        IF (.NOT. llchk) THEN
+            CALL prtout ('WARNING!!! 
+     $          Pb in combining field number =', kfield, 2)
+            CALL prtout ('Different size for auxilary field number =',
+     $          jc, 2)
+            istop = istop + 1
+        ENDIF 
+ 110  CONTINUE 
+      IF (istop .GT. 0) CALL HALTE('STOP in blasnew')
+C
+C
+C*    2. Linear combination
+C        ------------------
+C
+C* Multiply current field by main coefficient
+C
+      DO 210 ja = 1, kmsize
+        pfild(ja) = pmcoeff * pfild(ja)
+ 210  CONTINUE
+C
+C* Combine with other fields if required
+C
+      IF (kaux .GE. 1) THEN 
+          DO 220 jc = 1, kaux
+            DO 230 ja = 1, kmsize
+              pfild(ja) = pfild(ja) + pacoeff(jc) *
+     $                    paux(kaddr(jc)+ja-1)
+ 230        CONTINUE
+ 220      CONTINUE
+      ENDIF 
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine blasnew ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/blasold.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/blasold.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/blasold.f	(revision 1677)
@@ -0,0 +1,144 @@
+      SUBROUTINE blasold (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr,
+     $                    kasize, pacoeff, ksiztot, paux)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *blasold* - Stupid blas routine
+C
+C     Purpose:
+C     -------
+C     Do linear combination of fields with given coefficients
+C     before interpolation
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *blasold (pfild ,kmsize, kfield, pmcoeff, kaux, kaddr,
+C                         kasize, pacoeff, ksiztot, paux)*
+C
+C     Input:
+C     -----
+C                pfild   : field array to be modified (real 1D)
+C                kmsize  : size of the field array (integer)
+C                kfield  : field identificator number (integer)
+C                pmcoeff : field multiplicative coefficient (real)
+C                kaux    : number of combined auxilary fields (integer)
+C                kaddr   : pointer for auxilary fields (integer 1D)
+C                kasize  : size of auxilary fields (integer 1D)
+C                pacoeff : auxilary field multiplicative coefficient (real 1D)
+C                ksiztot : total size of work memory used (integer)
+C                paux    : global work array (real 1D)
+C
+C     Output:
+C     ------
+C                pfild   : new field array (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(kmsize)
+      REAL (kind=ip_realwp_p) paux(ksiztot), pacoeff(kaux)
+      INTEGER (kind=ip_intwp_p) kaddr(kaux), kasize(kaux)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) istop
+      LOGICAL llchk
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE blasold  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Do linear combination of fields'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      istop = 0
+C
+C* Check all fields have same dimensions as current field
+C
+      DO 110 jc = 1, kaux
+        llchk = (kasize(jc) - kmsize) .EQ. 0
+        IF (.NOT. llchk) THEN
+            CALL prtout ('WARNING!!! 
+     $          Pb in combining field number =', kfield, 2)
+            CALL prtout ('Different size for auxilary field number =',
+     $          jc, 2)
+            istop = istop + 1
+        ENDIF 
+ 110  CONTINUE 
+      IF (istop .GT. 0) CALL HALTE('STOP in blasold')
+C
+C
+C*    2. Linear combination
+C        ------------------
+C
+C* Multiply current field by main coefficient
+C
+      DO 210 ja = 1, kmsize
+        pfild(ja) = pmcoeff * pfild(ja)
+ 210  CONTINUE
+C
+C* Combine with other fields if required
+C
+      IF (kaux .GE. 1) THEN 
+          DO 220 jc = 1, kaux
+            DO 230 ja = 1, kmsize
+              pfild(ja) = pfild(ja) + pacoeff(jc) *
+     $                    paux(kaddr(jc)+ja-1)
+ 230        CONTINUE
+ 220      CONTINUE
+      ENDIF 
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '--------- End of routine blasold ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/calend.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/calend.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/calend.f	(revision 1677)
@@ -0,0 +1,178 @@
+      SUBROUTINE calend (kdini, kmini, kyini, kinc, kcal,
+     $                   kdfin, kmfin, kyfin, klmo)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *calend*  - Calendar routine
+C
+C     Purpose:
+C     -------
+C     Updates the calendar values. Date is of the form YYYYMMDD.
+C     Increases day by day the date, updates if necessary the month 
+C     and the year.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *calend (kdini, kmini, kyini, kinc, kcal
+C                        kdfin, kmfin, kyfin, klmo)*
+C
+C     Input:
+C     -----
+C                kdini,kmini,kyini : initial date (day,month,year)
+C                kinc              : number of days to increment
+C                kcal              : calendar type
+C
+C     Output:
+C     ------
+C                kdfin,kmfin,kyfin : final date
+C                klmo(12)          : length of the 12 months
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       S. Valcke      99/03/15  year is leap if divible by 4 but
+C                                          not by 100, leap if div. by 400
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) klmo(12)
+C
+C* ---------------------------- Local declarations -------------------
+C
+      LOGICAL lleap
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Length of the months
+C        --------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE calend  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Updates calendar values'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Calculate month lengths for current year
+C
+      IF (kcal .eq. 0 .or. kcal .eq. 1) THEN
+
+        DO 110 jm = 1, 12
+          klmo(jm) = 31
+          IF (jm .eq. 4 .or. jm .eq. 6 .or.
+     $        jm .eq. 9 .or. jm .eq. 11) THEN
+              klmo(jm) = 30
+          ENDIF
+          IF (jm .eq. 2) THEN
+C
+C* Leap years
+C
+            lleap = .FALSE.
+            IF (kcal .eq. 1) THEN
+              IF (MOD(kyini,4) .eq. 0) lleap = .TRUE.
+              IF (MOD(kyini,100) .eq. 0) lleap = .FALSE.
+              IF (MOD(kyini,400) .eq. 0) lleap = .TRUE.
+            ENDIF
+            IF (lleap) THEN
+                klmo(jm) = 29
+              ELSE
+                klmo(jm) = 28
+            ENDIF
+          ENDIF
+ 110    CONTINUE
+        kdfin = kdini
+        kmfin = kmini
+        kyfin = kyini
+C
+C
+C*    2. Loop on the days
+C        ----------------
+C
+        DO 210 jd = 1, kinc
+          kdfin = kdfin + 1
+          IF (kdfin .le. klmo(kmfin)) GOTO 210
+          kdfin = 1
+          kmfin = kmfin + 1
+          IF (kmfin .le. 12) GOTO 210
+          kmfin = 1
+          kyfin = kyfin + 1
+C
+C* Leap years
+C
+          lleap = .FALSE.
+          IF (kcal .eq. 1) THEN
+            IF (MOD(kyfin,4) .eq. 0) lleap = .TRUE.
+            IF (MOD(kyfin,100) .eq. 0) lleap = .FALSE.
+            IF (MOD(kyfin,400) .eq. 0) lleap = .TRUE.
+          ENDIF
+          IF (lleap) THEN
+              klmo(2) = 29
+            ELSE
+              klmo(2) = 28
+          ENDIF
+ 210    CONTINUE
+      ELSE
+C
+C* Calculate month lengths for current year
+C
+        DO 310 jm = 1, 12
+          klmo(jm) = kcal
+ 310    CONTINUE
+        kdfin = kdini
+        kmfin = kmini
+        kyfin = kyini
+C
+C*    2. Loop on the days
+C        ----------------
+        DO 410 jd = 1, kinc
+          kdfin = kdfin + 1
+          IF (kdfin .le. klmo(kmfin)) GOTO 410
+          kdfin = 1
+          kmfin = kmfin + 1
+          IF (kmfin .le. 12) GOTO 410
+          kmfin = 1
+          kyfin = kyfin + 1
+ 410    CONTINUE
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine calend ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/chkfld.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/chkfld.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/chkfld.f	(revision 1677)
@@ -0,0 +1,303 @@
+      SUBROUTINE chkfld (cdname, cdlab, pfild, kmask, psurf, 
+     $    ksize, klon, kflag)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *chkfld*  - Perform basic checks on a given field array
+C
+C     Purpose:
+C     -------
+C     Calculate mean and extremum values of a real array
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *chkfld (cdname, cdlab, pfild, kmask, psurf, ksize, klon,
+C                        kflag)*
+C
+C     Input:
+C     -----
+C                cdname : symbolic name of the field to be checked
+C                cdlab  : definition of the field to be checked
+C                pfild  : field array (real 1D)
+C                kmask  : associated mask array (integer 1D)
+C                psurf  : surface array (real 1D)
+C                ksize  : field array dimension
+C                klon   : number of longitudes
+C                kflag  : flag to compute integral of field
+C     
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     ssumr, rmaxim, rminim
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.1       L. Terray      96/09/25  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      IMPLICIT NONE
+      EXTERNAL ssumr, rminim, rmaxim
+      INTEGER (kind=ip_intwp_p) ksize 
+      REAL (kind=ip_realwp_p) pfild(ksize), psurf(ksize)
+      REAL (kind=ip_realwp_p) zmean, zglomax, zglomin, zmer, zmermax
+      REAL (kind=ip_realwp_p) zmermin, zterre, zsolmax, zsolmin
+      REAL (kind=ip_realwp_p) ztmp, zglo, zsea, zland
+      REAL (kind=ip_realwp_p) ssumr, rminim, rmaxim
+      INTEGER (kind=ip_intwp_p) iiglomax, ijglomax, iiglomin 
+      INTEGER (kind=ip_intwp_p) ijglomin, imer, iimermax, ijmermax
+      INTEGER (kind=ip_intwp_p) iimermin, ijmermin, iterre, iisolmax 
+      INTEGER (kind=ip_intwp_p) ijsolmax, iisolmin, ijsolmin
+      INTEGER (kind=ip_intwp_p) klon, jn, iflag, isolmin, isolmax
+      INTEGER (kind=ip_intwp_p) imermin, imermax, ji, kflag
+      INTEGER (kind=ip_intwp_p) iglomin, iglomax   
+      INTEGER (kind=ip_intwp_p) kmask(ksize)
+      CHARACTER*8 cdname
+      CHARACTER*32 cdlab
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations
+C        ---------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE chkfld  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1010) cdname, cdlab
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Initialization of counters and sums
+C
+      iterre = 0
+      imer = 0
+      zmean = 0.0
+      zterre = 0.0
+      zmer = 0.0
+C
+C* Formats
+C
+ 1010 FORMAT(5X,' Field alias name is = ',A8,
+     $     /,5X,' Its definition is   = ',A32)
+C
+C
+C*    2. Basic checks
+C        ------------
+C
+C* Calculate the mean; first the global one
+C
+      IF (ksize .GT. 0) THEN 
+          zmean = ssumr (pfild, ksize) / float(ksize)
+        ELSE
+          WRITE(UNIT = nulou,FMT = 2010)
+          CALL HALTE('STOP in chkfld')
+      ENDIF 
+C
+C* The other ones
+C
+      DO 210 jn = 1, ksize
+        IF (kmask(jn) .EQ. 0) THEN
+            imer = imer + 1
+            zmer = zmer + pfild(jn)
+          ELSE IF (kmask(jn) .EQ. 1) THEN
+            iterre = iterre + 1
+            zterre = zterre + pfild(jn)
+        ENDIF 
+ 210  CONTINUE 
+      IF (imer .GT. 0) THEN 
+          zmer = zmer / float(imer)
+        ELSE
+         WRITE(UNIT = nulou,FMT = 2020)
+         CALL HALTE('STOP in chkfld')
+      ENDIF 
+      IF (iterre .GT. 0) THEN 
+          zterre = zterre / float(iterre)
+        ELSE
+         WRITE(UNIT = nulou,FMT = 2030)
+      ENDIF 
+C
+C* Calculate extrema
+C
+      iflag = 0
+      zglomin = rminim (pfild, kmask, ksize, iglomin, iflag)
+      zglomax = rmaxim (pfild, kmask, ksize, iglomax, iflag)
+C* Indexes for minimum
+      IF (mod(iglomin,klon) .EQ. 0) THEN
+          ijglomin = iglomin / klon
+          iiglomin = klon
+        ELSE 
+          ztmp = float(iglomin/klon)
+          ijglomin = int(ztmp) + 1
+          iiglomin = iglomin - (ijglomin -1) * klon
+      ENDIF
+C* Indexes for maximum
+      IF (mod(iglomax,klon) .EQ. 0) THEN
+          ijglomax = iglomax / klon
+          iiglomax = klon
+        ELSE 
+          ztmp = float(iglomax/klon)
+          ijglomax = int(ztmp) + 1
+          iiglomax = iglomax - (ijglomax -1) * klon
+      ENDIF
+C
+C* Land
+C
+      iflag = 1
+      zsolmin = rminim (pfild, kmask, ksize, isolmin, iflag)
+      zsolmax = rmaxim (pfild, kmask, ksize, isolmax, iflag)
+C* Indexes for minimum
+      IF (mod(isolmin,klon) .EQ. 0) THEN
+          ijsolmin = isolmin / klon
+          iisolmin = klon
+        ELSE 
+          ztmp = float(isolmin/klon)
+          ijsolmin = int(ztmp) + 1
+          iisolmin = isolmin - (ijsolmin -1) * klon
+      ENDIF
+C* Indexes for maximum
+      IF (mod(isolmax,klon) .EQ. 0) THEN
+          ijsolmax = isolmax / klon
+          iisolmax = klon
+        ELSE 
+          ztmp = float(isolmax/klon)
+          ijsolmax = int(ztmp) + 1
+          iisolmax = isolmax - (ijsolmax -1) * klon
+      ENDIF
+C
+C* Sea
+C
+      iflag = 2
+      zmermin = rminim (pfild, kmask, ksize, imermin, iflag)
+      zmermax = rmaxim (pfild, kmask, ksize, imermax, iflag)
+C* Indexes for minimum
+      IF (mod(imermin,klon) .EQ. 0) THEN
+          ijmermin = imermin / klon
+          iimermin = klon
+        ELSE 
+          ztmp = float(imermin/klon)
+          ijmermin = int(ztmp) + 1
+          iimermin = imermin - (ijmermin -1) * klon
+      ENDIF
+C* Indexes for maximum
+      IF (mod(imermax,klon) .EQ. 0) THEN
+          ijmermax = imermax / klon
+          iimermax = klon
+        ELSE 
+          ztmp = float(imermax/klon)
+          ijmermax = int(ztmp) + 1
+          iimermax = imermax - (ijmermax -1) * klon
+      ENDIF
+C
+C* Print results
+C
+      WRITE(UNIT = nulou,FMT = 2040) cdname
+      WRITE(UNIT = nulou,FMT = 2050)
+      WRITE(UNIT = nulou,FMT = 2060) zmean, 
+     $    zglomax, iiglomax, ijglomax,
+     $    zglomin, iiglomin, ijglomin,
+     $    imer, zmer, 
+     $    zmermax, iimermax, ijmermax,
+     $    zmermin, iimermin, ijmermin,
+     $    iterre, zterre, 
+     $    zsolmax, iisolmax, ijsolmax,
+     $    zsolmin, iisolmin, ijsolmin
+C
+C* Formats
+C
+ 2010 FORMAT(' WARNING: total number of points .LE. 0 ')
+ 2020 FORMAT(' WARNING: number of sea points .LE. 0 ')
+ 2030 FORMAT(' WARNING: number of land points .LE. 0 ',
+     $       /,' This must be a sea-world run ')
+ 2040 FORMAT(/,15X,'  Field checks: ',A8)
+ 2050 FORMAT(15X,'  ************  ',/)
+ 2060 FORMAT(/,10X,'  Global average     = ',E22.7,
+     $       /,10X,'  Global maximum     = ',E22.7,
+     $    '  Pt i-j = ',I3,2X,I3,
+     $       /,10X,'  Global minimum     = ',E22.7,
+     $    '  Pt i-j = ',I3,2X,I3,
+     $       /,10X,'  Ocean grid points  = ',I6,
+     $       /,10X,'  Ocean  average     = ',E22.7,
+     $       /,10X,'  Ocean  maximum     = ',E22.7,
+     $    '  Pt i-j = ',I3,2X,I3,
+     $       /,10X,'  Ocean  minimum     = ',E22.7,
+     $    '  Pt i-j = ',I3,2X,I3,
+     $       /,10X,'  Land grid points   = ',I6,
+     $       /,10X,'  Land  average      = ',E22.7,
+     $       /,10X,'  Land  maximum      = ',E22.7,
+     $    '  Pt i-j = ',I3,2X,I3,
+     $       /,10X,'  Land  minimum      = ',E22.7,
+     $    '  Pt i-j = '
+     $    ,I3,2X,I3,/)
+C
+C
+C*    3. Calculate integral of current field if needed
+C        ------------------------------------------------------
+C
+      IF (kflag .EQ. 1) THEN
+          zglo = 0.0
+          zsea = 0.0
+          zland = 0.0
+C
+C* The integral is performed on all and unmasked points
+C
+          DO 310 ji = 1, ksize
+            zsea = zsea + pfild(ji) * psurf(ji) * float(1 - kmask(ji))
+            zland = zland + pfild(ji) * psurf(ji) * float(kmask(ji))
+            zglo = zglo + pfild(ji) * psurf(ji)
+ 310      CONTINUE 
+          WRITE(UNIT = nulou,FMT = 3010)  zglo, zsea, zland       
+      ENDIF
+C
+C* Formats
+C 
+ 3010 FORMAT(/,10X,'  Earth integral       = ',E22.7,
+     $       /,10X,'  Ocean integral       = ',E22.7,
+     $       /,10X,'  Land  integral       = ',E22.7)
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          ---------- End of routine chkfld --------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/chkpar.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/chkpar.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/chkpar.f	(revision 1677)
@@ -0,0 +1,173 @@
+      SUBROUTINE chkpar
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *chkpar*  - Parameter checking
+C
+C     Purpose:
+C     -------
+C     Checks option compatibility between oasis and remote models
+C     as well as some basic dimension checks
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *chkpar*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C
+C     Externals:
+C     ---------
+C     imaxim
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.2       L. Terray      97/11/13  added: check nitfn if cchan
+C                                                 equals NONE
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       S. Valcke      99/10/12  check if nninnfl and nninnflg
+C                                          are different
+C       2.4       S. Valcke      2K/02/03  check CLIM_MaxPOrt and jpfield
+C       2.4       S. Valcke      2K/02/03  check CLIM_MaxSegment and jpparal
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* --------------- Include files and use of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_string
+      USE mod_extrapol
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: itime, 
+     $    iexch
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Allocations and Initializations
+C        -------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE chkpar  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' control of run time options'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* In the CLIM CASE, mstep, mfcpl and mdt are not defined anymore in inicmc.f.
+C
+      IF (cchan.ne.'MPI1'.and.cchan.ne.'MPI2') then
+C
+C* Array allocation
+C
+          ALLOCATE (itime(ig_nmodel))
+          ALLOCATE (iexch(ig_nmodel))
+C
+C* Initialization of remote models time variables.
+C
+          DO 110 jm = 1, ig_nmodel
+            itime(jm) = mstep(jm) * mdt(jm)
+            iexch(jm) = mfcpl(jm) * mdt(jm)
+ 110      CONTINUE
+
+C
+C*    2. Basic checks
+C        ------------
+C
+C*    3. Time compatibility checks
+C        -------------------------
+C
+          DO 310 jm = 1, ig_nmodel
+            WRITE (UNIT = nulou,FMT = *)'itime ',itime(jm)
+            WRITE (UNIT = nulou,FMT = *)'ntime ',ntime
+            IF (itime(jm) .NE. ntime) THEN
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>> : total runtime for model',jm
+                WRITE (UNIT = nulou,FMT = *)
+     $              '          incompatible with coupler total time '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ======         =======              '
+                WRITE (UNIT = nulou,FMT = *) ' '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' The current simulation uses asynchroneous 
+     $              coupling'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              '                             -------------'
+                WRITE (UNIT = nulou,FMT = *) ' '
+            ENDIF
+C
+C* The exchange frequency data sent from remote models is the
+C  smallest frequency used in a given model. This is a crude 
+C  check of the compatibility of coupling options.
+C
+            WRITE (UNIT = nulou,FMT = *)'iexch ',iexch(jm)
+            WRITE (UNIT = nulou,FMT = *)'nstep ',nstep
+            IF (MOD(iexch(jm),nstep) .NE. 0) THEN
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>> : exchange time incompatible with model',
+     $              jm
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ======            =====          '
+                WRITE (UNIT = nulou,FMT = *) ' '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' We STOP        !!! rerun with new  parameters'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              '                               ---------------'
+                WRITE (UNIT = nulou,FMT = *) ' '
+                CALL HALTE ('STOP in chkpar')
+            ENDIF
+ 310      CONTINUE 
+          DEALLOCATE (itime)
+          DEALLOCATE (iexch)
+      ENDIF
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          ---------- End of routine chkpar --------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/chksgc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/chksgc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/chksgc.F	(revision 1677)
@@ -0,0 +1,124 @@
+      SUBROUTINE chksgc
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *chksgc*  - Initialize signal handling
+C
+C     Purpose:
+C     -------
+C     Initialize signal handling related to fork stuff and fpe trapping
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *chksgc*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     fsigctl, signal, ferror, getfpe
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       L. Terray      97/12/24  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C       2.5       S. Valcke      2K/09/04  Remove cmach
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+C
+C* ---------------------------- External declarations -------------------
+C
+      EXTERNAL ferror, getfpe
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE chksgc  -  Level C'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Initialize signal handling '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C
+C*    2. Signal handling initialization
+C        ------------------------------
+C 1- Insure proper termination in case of child process death
+C 2- Catch floating point error within OASIS
+C
+C* Case PIPE-CRAY
+C
+#ifdef use_comm_PIPE
+          CALL fsigctl ('REGISTER', 'SIGCLD', ferror)
+          CALL fsigctl ('REGISTER', 'SIGFPE', getfpe)
+C
+C* Case SIPC,GMEM-IEEE
+C
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+          CALL fpecatch
+
+C
+C* Child process death trapping only for SIPC (taken care thru MPI for GMEM)
+C
+#ifdef use_comm_SIPC
+             CALL cldcatch
+#endif
+C
+C* Others
+C
+#else
+          IF (nlogprt .GE. 2) THEN 
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' CLIM or exotic cases ===>>> No signal handling' 
+          ENDIF
+#endif
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine chksgc ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/cldcatch.c
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/cldcatch.c	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/cldcatch.c	(revision 1677)
@@ -0,0 +1,6 @@
+#ifdef use_comm_SIPC
+#include <signal.h>
+extern void ferror_();
+void cldcatch_()
+{   signal(SIGCLD,ferror_); }
+#endif
Index: CPL/oasis3/trunk/src/mod/oasis3/src/cldignore.c
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/cldignore.c	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/cldignore.c	(revision 1677)
@@ -0,0 +1,6 @@
+#ifdef use_comm_SIPC
+#include <signal.h>
+extern void fignore_();
+void cldignore_()
+{   signal(SIGCLD,fignore_); }
+#endif
Index: CPL/oasis3/trunk/src/mod/oasis3/src/coasts.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/coasts.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/coasts.f	(revision 1677)
@@ -0,0 +1,212 @@
+      SUBROUTINE coasts (plon, plat, kmsk, kmskval, klon, klat, kmesh)
+C
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *coasts* - locate coastal points where SST must be extrapolated
+C                when using surfmesh interpolation.
+C
+C     Purpose:
+C     -------
+C     This routine is designed to detect coastal points where there is
+C     mismatch between the atmosphere and ocean land sea masks and
+C     where this mismatch could result in the atmosphere (undesirably)
+C     'seeing' climatological SST's directly adjacent to ocean model SST's.
+C     Where this situation arises, suitable neighbours from where
+C     ocean model SST's may be extrapolated are located.
+C     
+C     NB: This is only for use with 'SURFMESH' interpolation of SST's.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *coasts*(plon, plat, kmsk, kmskval, klon, klat, kmesh)*
+C
+C     Input:
+C     -----
+C                plon    : target grid longitude array (real 2D) 
+C                plat    : target grid latitude array (real 2D) 
+C                klon    : number of longitude for target grid (integer)
+C                klat    : number of latitude for target grid (integer)
+C                kmsk    : target grid sea-land mask (integer 2D)
+C                kmskval : sea-land mask value (integer)
+C                kmesh   : overlap array (integer 2D)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C         indx(4) - stores indices for neighbours
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.1       R. Sutton      24/11/95  Original
+C       2.0       L. Terray      26/12/95  Modified: to suit OASIS 2.0
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* --------------- Include files and USE of modules ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_coast
+      USE mod_unit
+      USE mod_smooth
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) plon(klon,klat), plat(klon,klat)
+      INTEGER (kind=ip_intwp_p) kmsk(klon,klat), kmesh(klon,klat)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) indx(4)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE coasts  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *)
+     $     ' locate any coastal points where SST must be extrapolated'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      ncoast = 0
+      indx(:)=0
+C
+C
+C*    2. Locate coastal points and neighbours from where to do extrapolation 
+C        -------------------------------------------------------------------
+C
+C* Loop between southern and northern boundaries   
+C (Range of latitude is set by parameters defined in blkdata.)
+C
+      DO 210 jj = nsltb+1, nnltb-1
+        DO 220 ji = 1, klon 
+C
+C* Find all grid squares which are ocean on the atmosphere grid but
+C  have no ocean underlying them on the ocean grid
+C
+          IF (kmsk(ji,jj) .NE.  kmskval .AND. 
+     $        kmesh(ji,jj) .EQ. 0) THEN
+              is = jj-1
+              in = jj+1
+              iw = ji-1
+              ie = ji+1
+C
+C* For an atmospheric domain that is periodic in longitude
+C
+              IF (iw .EQ. 0) iw = klon
+              IF (ie .GT. klon) ie = ie - klon
+C
+C* For a domain that is not periodic in longitude
+C          if (iw .eq. 0) iw=1
+C          if (ie .gt. klon) ie=klon
+C
+C* Search for neighbours from which ocean model SST may be extrapolated.
+C     
+              inbor = 0
+              IF (kmsk(iw,jj) .EQ. 0 .AND. kmesh(iw,jj) .NE. 0) THEN
+                  inbor = inbor + 1
+                  indx(inbor) = iw + (jj-1) * klon
+              ENDIF
+              IF (kmsk(ie,jj) .EQ. 0 .AND. kmesh(ie,jj) .NE. 0) THEN
+                  inbor = inbor + 1
+                  indx(inbor)= ie + (jj-1) * klon
+              ENDIF
+              IF (kmsk(ji,is) .EQ. 0 .AND. kmesh(ji,is) .NE. 0) THEN
+                  inbor = inbor + 1
+                  indx(inbor) = ji + (is-1) * klon
+              ENDIF
+              IF (kmsk(ji,in) .EQ. 0 .AND. kmesh(ji,in) .NE. 0) THEN
+                  inbor = inbor + 1
+                  indx(inbor) = ji + (in-1) * klon
+              ENDIF
+C
+C* Store location of coastal point, number of suitable
+C  neighbours and their locations.
+C  Note that if there are no neighbours the point must
+C  be an inland sea on the atmosphere grid for which 
+C  we do not want to extrapolate the ocean SST's 
+C
+              IF (inbor .GT. 0) THEN
+                  ncoast = ncoast + 1
+                  npcoast(ncoast,1) = ji + (jj-1) * klon
+                  npcoast(ncoast,2) = inbor
+                  DO 230 jkbor = 1, inbor
+                    npcoast(ncoast,2+jkbor) = indx(jkbor)
+ 230              CONTINUE
+              ENDIF
+          ENDIF
+ 220    CONTINUE
+ 210  CONTINUE
+C
+C
+C*    3. Writing results
+C        ---------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    'Number of coastal ocean squares on the atmosphere grid '//
+     $    'for which there'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    'are no underlying ocean squares on the ocean grid = ',ncoast
+          WRITE (UNIT = nulou,FMT = *) ' ' 
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    'Coordinates  nbor  Coordinates of neighbours '
+          do 310 jn = 1, ncoast
+            ii = icoor(npcoast(jn,1),klon)
+            ij = jcoor(npcoast(jn,1),klon)
+            WRITE (UNIT = nulou,FMT = 3100) 
+     $       plon(ii,ij),plat(ii,ij),npcoast(jn,2),
+     $       (plon(icoor(npcoast(jn,jkbor),klon),
+     $            jcoor(npcoast(jn,jkbor),klon)),
+     $        plat(icoor(npcoast(jn,jkbor),klon),   
+     $            jcoor(npcoast(jn,jkbor),klon)), 
+     $       jkbor=3,2+npcoast(jn,2))
+ 310      CONTINUE
+      ENDIF
+C
+C* Formats
+C
+ 3100 FORMAT (1X,'(',F5.1,',',F5.1,')  ',I1,
+     $       4X,4('(',F5.1,',',F5.1,') '))
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           --------- End of routine coasts ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/conserv.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/conserv.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/conserv.f	(revision 1677)
@@ -0,0 +1,186 @@
+      SUBROUTINE conserv (pfldb, ksizb, kmskb, psurfb,
+     $                    pflda, ksiza, kmska, psurfa, 
+     $                    psgrb, psgra, cdmet)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *conserv* - Flux conservation routine
+C
+C     Purpose:
+C     -------
+C     Use global lagrange multiplier to insure conservation
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *conserv (pfldb, ksizb, kmskb, psurfb,
+C                         pflda, ksiza, kmska, psurfa, cdmet)*
+C
+C     Input:
+C     -----
+C                pflda  : field on target grid (real 1D)
+C                pfldb  : field on source grid (real 1D)
+C                kmska  : mask for target grid (integer 1D)
+C                kmskb  : mask for source grid (integer 1D)
+C                psurfa : surfaces for target grid meshes (real 1D)
+C                psurfb : surfaces for source grid meshes (real 1D)
+C                ksizb  : source arrays size (integer)
+C                ksiza  : target arrays size (integer)
+C                psgrb  : work array (real 1D)
+C                psgra  : work array (real 1D)
+C                cdmet  : conservation method (character string)
+C
+C     Output:
+C     ------
+C                pflda  : field on target grid with conservation (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (2000)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.1       L. Terray      96/09/01  modified: printing
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.4       S. Legutke     00/07/12  conservation calculation
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pflda(ksiza), pfldb(ksizb)
+      REAL (kind=ip_realwp_p) psurfa(ksiza), psurfb(ksizb)
+      REAL (kind=ip_realwp_p) psgra(ksiza), psgrb(ksizb)
+      INTEGER (kind=ip_intwp_p) kmska(ksiza), kmskb(ksizb)
+      CHARACTER*8 cdmet
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE conserv  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Global or local flux conservation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      zrad = 6371229.
+      zrad2 = zrad * zrad
+      zradi = 1./zrad2
+
+C
+C
+C*    2. Calculate mesh surfaces
+C        -----------------------
+C
+      DO 210 ji = 1, ksiza
+        psgra(ji) = psurfa(ji) * zradi
+ 210  CONTINUE
+      DO 220 ji = 1, ksizb
+        psgrb(ji) = psurfb(ji) * zradi
+ 220  CONTINUE
+C
+C
+C*    3. Lagrange multiplier for global conservation
+C        -------------------------------------------
+C
+      IF (cdmet .EQ. 'GLOBAL') THEN
+          zflxa = 0.
+          ztsqi = 0.
+C
+C* Sum up flux on target grid
+C
+          DO 310 ji = 1, ksiza
+            IF (kmska(ji) .eq. 0) THEN
+                zflxa = zflxa + psgra(ji) * pflda(ji)
+CSL                ztsqi = ztsqi + psgra(ji) * psgra(ji)
+                ztsqi = ztsqi + psgra(ji)
+            ENDIF
+ 310      CONTINUE
+C
+C* Sum up flux on source grid
+C
+          zflxb = 0.
+          DO 320 ji = 1, ksizb
+            IF (kmskb(ji) .eq. 0) THEN
+                zflxb = zflxb + psgrb(ji) * pfldb(ji)
+            ENDIF
+ 320      CONTINUE
+C
+C* Get global correction
+C
+          zlagr = (zflxa - zflxb) / ztsqi
+C
+C* Constrained solution: the error is uniformly shared between sea points
+C
+          DO 330 ji = 1, ksiza
+            IF (kmska(ji) .EQ. 0) THEN
+CSL                pflda(ji) = pflda(ji) - zlagr * psgra(ji)
+                pflda(ji) = pflda(ji) - zlagr
+            ENDIF
+ 330      CONTINUE
+C
+C* Printing test
+C
+          zflxn = 0.
+          DO 340 ji = 1, ksiza
+            IF (kmska(ji) .eq. 0) THEN
+                zflxn = zflxn + psgra(ji) * pflda(ji)
+            ENDIF
+ 340      CONTINUE
+          IF (nlogprt .GE. 2) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $        ' Printing check for flux conservation '
+              WRITE (UNIT = nulou,FMT = *) ' '
+              WRITE (UNIT = nulou,FMT = *) 
+     $        ' Total flux on source grid ZFLXB = ',zflxb
+              WRITE (UNIT = nulou,FMT = *) 
+     $        ' Total flux on target grid ZFLXA = ',zflxa
+              WRITE (UNIT = nulou,FMT = *) 
+     $        ' Idem after conservation   ZFLXN = ',zflxn
+              WRITE (UNIT = nulou,FMT = *) ' '
+          ENDIF
+      ENDIF 
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine conserv ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/cookart.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/cookart.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/cookart.f	(revision 1677)
@@ -0,0 +1,359 @@
+      SUBROUTINE cookart (kindex, kfield)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *cookart* - More or less clever stuff
+C
+C
+C     Purpose:
+C     -------
+C     Do subgrid variability, flux conservation or
+C     stupid basic linear algebra stuff
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *cookart (kindex, kfield)*
+C
+C     Input:
+C     -----
+C       kindex : field identificator array (integer 1D)
+C       kfield : number of fields for current iteration (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C        zbncoef : additional field coefficients for blasnew (real 1D)
+C        iaddr   : memory allocation of the work array (integer 1D)
+C        isize   : memory allocation of the work array (integer 1D)
+C        iflag   : memory allocation of the work array (integer 1D)
+C        clbnfld : additional field names for blasnew (character 1D)
+C
+C     Externals:
+C     ---------
+C     conserv, subgrid, blasnew
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.1       L. terray      96/08/05  modified: subgrid analysis
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* --------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_rainbow
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: zbncoef
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iaddr, 
+     $    isize, iflag
+      INTEGER (kind=ip_intwp_p) :: il_err
+      CHARACTER(len=8),DIMENSION(:), ALLOCATABLE :: clbnfld 
+      CHARACTER*8 clconmet, clname,  cldqdt
+      CHARACTER*8 clfldcoa, clfldfin, clfic
+      LOGICAL lli, llj, llk, llt
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization and allocation of local arrays
+C        ---------------------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '            ROUTINE cookart  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '            ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Subgrid variability, blas and flux conservation '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+      ALLOCATE (zbncoef(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "zbncoef" allocation of 
+     $    cookart ',il_err,1)
+      zbncoef(:)=0
+      ALLOCATE (iaddr(0:ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "iaddr" allocation of 
+     $    cookart ',il_err,1)
+      iaddr(:)=0
+      ALLOCATE (isize(0:ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "isize" allocation of 
+     $    cookart ',il_err,1)
+      isize(:)=0
+      ALLOCATE (iflag(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "iflag" allocation of 
+     $    cookart ',il_err,1)
+      iflag(:)=0
+      ALLOCATE (clbnfld(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "clbnfld" allocation of 
+     $    cookart ',il_err,1)
+      clbnfld(:)=' '
+C
+
+C*    2. Do the job
+C        ----------
+C
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+        ifield = kindex(jf)
+        iadrold = nadrold(ifield)
+        iadrold_grid = nadrold_grid(ifield)
+        isizold = nsizold(ifield)
+        iadrnew = nadrnew(ifield)
+        iadrnew_grid = nadrnew_grid(ifield)
+        isiznew = nsiznew(ifield)
+        clname = cnamout(ifield)
+C
+C* Print field name
+C
+        IF (nlogprt .GE. 1) THEN 
+            CALL prcout('Treatment of field : ', clname, 2)
+        ENDIF
+C
+C* - Do additional analysis
+C
+        DO 220 ja = 1, ig_ntrans(ifield)
+C
+C* --->>> Flux conservation
+C
+          IF (canal(ja,ifield) .EQ. 'CONSERV') THEN
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+C
+C* Get conservation method and do the job
+C
+              clconmet = cconmet(ifield)
+              CALL conserv (fldold(iadrold), isizold,
+     $                      mskold(iadrold_grid), surold(iadrold_grid),
+     $                      fldnew(iadrnew), isiznew,
+     $                      msknew(iadrnew_grid), surnew(iadrnew_grid),
+     $                      work(1), work(1+isizold), clconmet)
+C
+C* --->>> Subgrid variability
+C
+C* We have to estimate  Fo = sum_a{ B(o,a)*(Fa + dFa/dTa * (To - Ta))}
+C  a and o mean coarse and fine grid respectively 
+C  with To on the fine grid initially
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'SUBGRID') THEN
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+C
+C* Get names for fields on both fine and coarse grids
+C
+              clfldcoa = cfldcoa(ifield)
+              clfldfin = cfldfin(ifield)
+C
+C* No coupling ratio needed unless subgrid deals with non solar flux
+C  Initialize anyway local variable cldqdt
+C
+              cldqdt = 'NONE'
+              IF (ctypsub(ifield) .EQ. 'NONSOLAR') THEN 
+                  cldqdt = cdqdt(ifield)
+              ENDIF
+C
+C* In order not to have problems for solar flux for the dimension checks
+C 
+              itot3 = isizold
+C
+C* Look for field data
+C
+              DO 230 jn = 1, ig_nfield
+C
+C* Find Ta field: initially on coarse grid
+C  The Ta field is in fact the To field 
+C  which has been interpolated at the previous timestep
+C
+                IF (cnaminp(jn) .EQ. clfldcoa) THEN
+                    iadr1 = nadrold(jn)
+                    itot1 = nsizold(jn)
+C
+C* Find additional field To on fine grid
+C
+                  ELSE IF (cnaminp(jn) .EQ. clfldfin) THEN
+                    iadr2 = nadrold(jn)
+                    itot2 = nsizold(jn)
+C
+C* Find dFa/dTa field :initially on coarse grid, corresponding to 
+C  the previous timestep
+C
+                  ELSE IF (cnaminp(jn) .EQ. cldqdt) THEN
+                    iadr3 = nadrold(jn)
+                    itot3 = nsizold(jn)
+                ENDIF
+ 230          CONTINUE
+C* Get Ta
+              DO 231 ji = 1, itot1
+                work(ji) = fldold(iadr1-1+ji)
+ 231          CONTINUE 
+C* Get To
+              DO 232 ji = 1, itot2
+                work(itot1+ji) = fldold(iadr2-1+ji)
+ 232          CONTINUE
+C* Get dFa/dTa only if we deal with non solar flux
+              IF (ctypsub(jf) .EQ. 'NONSOLAR') THEN 
+                  DO 234 ji = 1, itot3
+                    work(itot1+itot2+ji) = fldold(iadr3-1+ji)
+ 234              CONTINUE
+              ENDIF 
+C
+C* Check sizes
+C
+              lli = isizold .EQ. itot1
+              llj = isiznew .EQ. itot2
+              llk = isizold .EQ. itot3
+              IF (.NOT. lli) CALL prcout('WARNING: size mismatch
+     $            between coarse and initial field',clname,2)
+              IF (.NOT. llj) CALL prcout('WARNING: size mismatch
+     $            between final and fine field',clname,2)
+              IF (.NOT. llk) CALL prcout('WARNING: size mismatch
+     $            between coarse and dqdt field',clname,2)
+              llt = lli .AND. llj .AND. llk
+              IF (.NOT. llt) CALL HALTE('STOP in cookart')
+C
+C* Do the subgrid interpolation
+C
+C* assign local variables and get pointer for subgrid interpolation
+C
+              clfic = cgrdsub(ifield)
+              iunit = nlusub(ifield)
+              iloc = nsubfl(ifield)
+              ivoisin = nsubvoi(ifield)
+              ipdeb = (nsubfl(ifield)-1)*ig_maxsoa*ig_maxgrd+1
+              CALL subgrid (fldnew(iadrnew), fldold(iadrold),
+     $                      isiznew, isizold,
+     $                      work(1), work(1+isizold), 
+     $                      work(1+isizold+isiznew),
+     $                      clfic, iunit, iloc, clname,
+     $                      asubg(ipdeb), nsubg(ipdeb),
+     $                      ivoisin, lsubg(ifield), ctypsub(ifield))
+C
+C* --->>> Blasnew
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'BLASNEW') THEN
+C
+C* Assign local variables to main field coefficient and number of extra fields
+C
+              zfldcobn = afldcobn(ifield)
+              ibnfld = nbnfld(ifield)
+C
+C* Read in additional field names and related coefficients
+C
+              DO 240 jc = 1, ibnfld
+                clbnfld(jc) = cbnfld(jc,ifield)
+                zbncoef(jc) = abncoef(jc,ifield)
+ 240          CONTINUE
+C
+C* - Get the additional fields parameters (pointers and sizes)
+C
+              CALL szero( work, ig_work)
+              DO 250 jc = 1, ibnfld
+C
+C* Constant fields
+C
+                IF (clbnfld(jc) .EQ. 'CONSTANT') THEN
+                    isize(jc) = isiznew
+                ELSE
+C
+C* Others
+C 
+                    DO 260 jb = 1, ig_nfield
+C
+C* Check field names input list
+C
+                      IF (clbnfld(jc) .EQ. cnamout(jb)) THEN
+                          iflag(jc) = jb
+                      ENDIF 
+ 260                CONTINUE
+                    ipointer  = nadrnew(iflag(jc))
+                    isize(jc) = nsiznew(iflag(jc))
+                ENDIF 
+C
+C* Get memory adresses for array work
+C
+                IF (jc .EQ. 1) THEN
+                    iaddr(jc) = 1
+                ELSE
+                    iaddr(jc) = 1 + isize(jc-1)
+                ENDIF
+C
+C* Assign values to temporary array work
+C
+                IF (clbnfld(jc) .EQ. 'CONSTANT') THEN
+                    DO 270 jd = 1, isize(jc)
+                      work(iaddr(jc)+jd-1) = 1.0
+ 270                CONTINUE 
+                ELSE 
+                    DO 280 jd = 1, isize(jc)
+                      work(iaddr(jc)+jd-1) = fldnew(ipointer+jd-1)
+ 280                CONTINUE 
+                ENDIF 
+ 250          CONTINUE
+C
+C* Get total size for array work ( sum of additional fields sizes)
+C
+              isiztot = iaddr(ibnfld) + isize(ibnfld) - 1
+              CALL blasnew (fldnew(iadrnew), isiznew, ifield,
+     $                      zfldcobn, ibnfld, iaddr, isize,
+     $                      zbncoef, isiztot, work)
+          ELSE
+              CONTINUE 
+          END IF
+ 220    CONTINUE
+ 210  CONTINUE 
+C
+C
+C*    3. Deallocation and end of routine
+C        -------------------------------
+C
+      DEALLOCATE (zbncoef)
+      DEALLOCATE (iaddr)
+      DEALLOCATE (isize)
+      DEALLOCATE (iflag)
+      DEALLOCATE (clbnfld)
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine cookart ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/correct.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/correct.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/correct.f	(revision 1677)
@@ -0,0 +1,184 @@
+      SUBROUTINE correct (pfild, ksize, pmcoef, kaux, pacoef, pwork,
+     $                    kunit, cdfic, cdfld)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *correct* - Flux correction routine
+C
+C     Purpose:
+C     -------
+C     Use external data to modify coupling fields
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *correct (pfild, ksize, pmcoef, kaux, pacoef, pwork,
+C                         kunit, cdfic, cdfld)*
+C
+C     Input:
+C     -----
+C                pfild  : field on source grid (real 1D)
+C                ksize  : size of field array (integer)
+C                pmcoef : main field coefficient (real)
+C                kaux   : number of auxilary fields (integer)
+C                pacoef : auxilary field coefficients (real 1D)
+C                pwork  : temporary array to read auxilary fields (real 1D)
+C                kunit  : logical unit numbers for data files (INTEGER 1D)
+C                cdfic  : filenames for external data (character 1D)
+C                cdfld  : auxilary field names (character 1D) 
+C
+C     Output:
+C     ------
+C                pfild  : corrected field on source grid  (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(ksize), pwork(ksize), pacoef(kaux)
+      INTEGER (kind=ip_intwp_p) kunit(kaux)
+      CHARACTER*8 cdfic(kaux), cdfld(kaux)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clfic
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE correct  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Flux correction with external data'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* initialize error flag for I/O routine
+C
+      iflag = 0
+C
+C
+C*    2. Multiply main field by its coefficient
+C        --------------------------------------
+C
+      DO 210 ji = 1, ksize
+        pfild(ji) = pfild(ji) * pmcoef
+ 210  CONTINUE
+C
+C
+C*    3. Read external data and add it to main field
+C        -------------------------------------------
+C
+C* Loop on additional fields
+C
+      DO 310 ji = 1, kaux
+C
+C* Flush data files
+C
+        iunit = kunit(ji)
+        clfic = cdfic(ji)
+        CLOSE(UNIT = iunit, ERR = 3010, IOSTAT = ios)
+        WRITE(UNIT = nulou, FMT = 3100) iunit, clfic
+ 3010   CONTINUE
+        IF (ios .NE. 0) THEN
+            CALL prtout('WARNING: problem in closing unit',
+     $          iunit, 1)
+            CALL prtout('Error message number is = ', ios, 1)
+            CALL HALTE('STOP in correct')
+        ENDIF 
+        OPEN(UNIT=iunit,FILE=clfic,FORM='UNFORMATTED',
+     $      STATUS='UNKNOWN',ERR = 3020, IOSTAT = ios)
+        WRITE(UNIT = nulou, FMT = 3200) iunit, clfic
+ 3020   CONTINUE
+        IF (ios .NE. 0) THEN
+            CALL prtout('WARNING: problem in connecting unit',
+     $          iunit, 1)
+            CALL prtout('Error message number is = ', ios, 1)
+            CALL HALTE('STOP in correct')
+        ENDIF 
+C
+C* Reading of the auxilary fields
+C
+        CALL locread (cdfld(ji), pwork, ksize, kunit(ji), iflag)
+C
+C* Checking
+C
+        IF (iflag .NE. 0) THEN 
+            CALL prcout
+     $          ('WARNING: problem in reading field',
+     $          cdfld(ji), 1)
+            CALL prtout
+     $          ('Error reading logical unit', kunit(ji), 1)
+            CALL prcout
+     $          ('It is connected to file',cdfic(ji),1)
+            WRITE(UNIT = nulou,FMT = *) 
+     $          ' If very first iteration and parallel simulation '
+            WRITE(UNIT = nulou,FMT = *)
+     $          ' or sequential one starting with atmosphere '
+            WRITE(UNIT = nulou,FMT = *)
+     $          ' No file present !! It is normal !! '
+
+        ENDIF
+C
+C* Add to original field
+C
+        DO 320 jj = 1, ksize
+          pfild(jj) = pfild(jj) + pacoef(ji) * pwork(jj)
+ 320    CONTINUE 
+ 310  CONTINUE
+C
+C* Formats
+C
+ 3100 FORMAT(/,5X,' Unit ',I2,' has been disconnected from file ',A8)
+ 3200 FORMAT(/,5X,' Unit ',I2,' has been reconnected to file ',A8) 
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine correct ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/couple.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/couple.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/couple.f	(revision 1677)
@@ -0,0 +1,301 @@
+      PROGRAM couple
+C=====================================================================C
+C                                                                     C
+C                 ####     ##     ####     #     ####                 C
+C                #    #   #  #   #         #    #                     C
+C                #    #  #    #   ####     #     ####                 C
+C                #    #  ######       #    #         #                C
+C                #    #  #    #  #    #    #    #    #                C
+C                 ####   #    #   ####     #     ####                 C
+C                                                                     C
+C=====================================================================C
+C                                                                     C
+C            Ocean Atmosphere Sea Ice Soil Simulation Software        C 
+C                          -- VERSION 3_prism_2-3 --                  C
+C                                                                     C
+C MAIN CONTRIBUTORS: S. VALCKE, A. CAUBEL, R. VOGELSANG. D. DECLAT    C
+C                                                                     C
+C THIS VERSION WAS DEVELOPED UNDER THE EU FP6 PRISM PROJECT           C
+C CONTRACT NO: EVR1-CT-2001-40012-PRISM                               C
+C                                                                     C
+C              CLIMATE MODELLING AND GLOBAL CHANGE TEAM               C
+C                            C.E.R.F.A.C.S                            C
+C                      42, Ave. Gustave Coriolis                      C
+C                        31057  TOULOUSE CEDEX                        C
+C                              FRANCE                                 C
+C                                                                     C
+C=====================================================================C
+C                                                                     C
+C CONTACT SOPHIE VALCKE                                               C
+C             Email: oasishelp@cerfacs.fr Tel:(33)5.61.19.30.76       C
+C                                                                     C
+C   WITH QUESTIONS OR COMMENTS CONCERNING THIS SOFTWARE               C
+C                                                                     C
+C                                                                     C
+C=====================================================================C
+C                                                                     C
+C Reference for this software is:                                     C
+C S. Valcke, A. Caubel, R. Vogelsang, D. Declat, 2004,                C  
+C OASIS3 Ocean Atmosphere Sea Ice Soil User's Guide,                  C
+C Technical Report TR/CMGC/04/68, CERFACS, Toulouse, France           C
+C=====================================================================C
+C                                                                     C
+C Copyright © 2004 Centre Europeen de Recherche et Formation          C
+C Avancee en Calcul Scientifique (CERFACS).                           C
+C                                                                     C
+C This software and ancillary information called OASIS3 is free       C
+C software.  CERFACS has rights to use, reproduce, and distribute     C
+C OASIS3. The public may copy, distribute, use, prepare derivative    C 
+C works and                                                           C
+C publicly display OASIS3 under the terms of the Lesser GNU General   C
+C Public License (LGPL) as published by the Free Software Foundation, C
+C provided that this notice and any statement of authorship are       C
+C reproduced on all copies. If OASIS3 is modified to produce          C 
+C derivative works, such modified software should be clearly marked,  C 
+C so as not to confuse it with the OASIS3 version available           C
+C from CERFACS.                                                       C
+C                                                                     C
+C The developers of the OASIS3 software are researchers attempting to C
+C build a modular and user-friendly coupler accessible to the climate C
+C modelling community. Although we use the tool ourselves and have    C 
+C made every effort to ensure its accuracy, we can not make any       C
+C guarantees. We provide the software to you for free. In return, you C     
+C --the user--assume full responsibility for use of the software. The C
+C OASIS3 software comes without any warranties (implied or expressed) C 
+C and is not guaranteed to work for you or on your computer.          C 
+C Specifically,                                                       C
+C CERFACS and the various individuals involved in development and     C
+C maintenance of the OASIS3 software are not responsible for any      C
+C damage                                                              C
+C that may result from correct or incorrect use of this software.     C
+C                                                                     C
+C=====================================================================C
+C   V1.0 (2/94) IS THE ORIGINAL VERSION OF THIS SOFTWARE              C
+C   ***********                                                       C
+C                                                                     C
+C The OASIS software allows coupling of General Circulation Models of C
+C the Atmosphere and the Ocean (AGCM and OGCM).                       C
+C                                                                     C
+C---------------------------------------------------------------------C
+C   V1.1 (8/94) includes the following changes:                       C
+C   ***********                                                       C
+C                                                                     C
+C - Bug corrected for interpolation in fscint package near poles:     C
+C   different treatment for scalar and vector.                        C
+C   P. Braconnot, O. Marti, L. Terray                                 C
+C                                                                     C
+C - Extension of Z grids incorporated in fscint package.              C
+C   P. Braconnot, O. Marti, L. Terray                                 C
+C                                                                     C
+C - Bug corrected in prtfld routine in case nmode = 1,2 due to non    C
+C   initialized variables not taken care of by namelist options.      C
+C   L. Fairhead, L. Terray                                            C
+C                                                                     C
+C - Bug corrected in routines naflux, qlflux (argument list mismatch) C
+C   L. Terray                                                         C
+C                                                                     C
+C - Addition of fluxes to force a sea-ice model.                      C
+C   L. Terray, G. Garric                                              C
+C                                                                     C
+C - Sea-ice extent can be prescribed from climatology or read from    C
+C   ogcm + sea-ice model.                                             C
+C   L. Terray                                                         C
+C                                                                     C
+C - Adding of the no-interpolation case.                              C
+C   L. Terray                                                         C
+C                                                                     C
+C - Global flux conservation implemented.                             C
+C   L. Terray                                                         C
+C---------------------------------------------------------------------C
+C   V2.0 (1/96) is a major enhancement of the software.               C
+C   ***********                                                       C
+C                                                                     C
+C New main features are as follows:                                   C
+C                                                                     C
+C - Distributed computing allowed (Use of CLIM library based on PVM). C
+C                                                                     C
+C - Dynamic definition of coupling fields.                            C
+C                                                                     C
+C - Choice of the time coupling strategy.                             C
+C                                                                     C
+C - Binary format to transfer coupling fields.                        C
+C                                                                     C
+C - Workstation version.                                              C
+C                                                                     C
+C - And much more... (See manual for details).                        C
+C                                                                     C
+C---------------------------------------------------------------------C
+C   V2.2 (1/98) has some new interesting features:                    C
+C                                                                     C
+C - a new communication technique based on Sytem V shared memory      C
+C   segments developed by S.Saarinen (ECMWF)                          C
+C                                                                     C
+C - new extrapolation method                                          C
+C                                                                     C
+C - mode "interpolator only"                                          C
+C                                                                     C
+C - possibility to have an extended header for the coupling fields    C
+C                                                                     C
+C - new memory allocation in fscint package (with F90 features)       C
+C                                                                     C
+C - atmosphere and ocean toys provided with full environment for the  C
+C   pipe and svipc techniques                                         C
+C                                                                     C
+C The code has been successfully run on various platforms:            C
+C Crays (C90, J90, T3E), VPPs (300, 700), SGIs (Origin 200, 2000) ... C
+C The portability on NEC machines is currently being investigated     C
+C                                                                     C
+C---------------------------------------------------------------------C
+C   V2.3 (10/99) has some new features:                               C
+C                                                                     C
+C - a new communication technique for NEC machines which is based on  C
+C   the global memory concept                                         C
+C                                                                     C
+C - optimization of the extrapolation package                         C
+C                                                                     C
+C - introduction of several printing levels for oasis output file     C
+C                                                                     C
+C - new definition of gaussian grids                                  C
+C                                                                     C
+C - new definition of grid periodicity                                C
+C                                                                     C
+C - bugs correction: fscint, fiasco, leap years etc ...               C
+C 
+C---------------------------------------------------------------------C
+C   V2.4 (05/2k) new features:                                        C
+C                                                                     C 
+C - the possibility of using MPI2 as message passing library within   C
+C   the CLIM communication technique                                  C
+C                                                                     C
+C - the possibility of using the GMEM technique to couple a           C
+C   MPI parallel model                                                C      
+C                                                                     C
+C---------------------------------------------------------------------C
+C  V3 prism_1-2 (09/03) see User's Guide                              C
+C                                                                     C
+C---------------------------------------------------------------------C
+C  V3 prism_2-2 (06/04) see User's Guide                              C
+C                                                                     C
+C---------------------------------------------------------------------C
+C  V3 prism_2-3 (07/04) see User's Guide                              C
+C                                                                     C
+C---------------------------------------------------------------------C
+C=====================================================================C
+C                                                                     C
+C                ####     ##     ####      #     ####                 C
+C               #    #   #  #   #          #    #                     C
+C               #    #  #    #   ####      #     ####                 C
+C               #    #  ######       #     #         #                C
+C               #    #  #    #  #    #     #    #    #                C
+C                ####   #    #   ####      #     ####                 C
+C                                                                     C
+C=====================================================================C
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Open main output file for OASIS coupler.
+C        ----------------------------------------
+C
+C* First we open output file connected to unit nulou = 6
+C
+      nulou = 6
+      iost = 0
+      OPEN (UNIT = nulou,FILE ='cplout',STATUS='UNKNOWN',
+     $      FORM ='FORMATTED',ERR = 110,IOSTAT = iost)
+C
+C* Let 's the fun begin
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                ANOTHER FANTASTIC RUN OF THE SUPER '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                  Ocean Atmosphere Sea Ice Soil '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                  ----------------------------- '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '               A fractal, random and poetic software '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                for surrealistic simulations of the '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                           EARTH CLIMATE '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '                           ************* '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           PROGRAM couple  -  Level 0'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $       ' Open main input-output files and launch the simulation'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout 
+     $    ('Open output file cplout connected to unit',nulou,1)
+ 110  CONTINUE
+      IF (iost .ne. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' ===>>> : ERROR opening output FILE'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' ======   =====                ===='
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' Logical unit ',nulou,' error number = ',iost
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' We STOP!!! Verify the file cplout'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL HALTE ('STOP in couple')
+      ENDIF
+C
+C
+C*    2. Open main input file for OASIS coupler.
+C        ----------------------------------------
+C
+C* Open input file connected to unit nulin=4
+C
+      nulin = 4
+      iost = 0
+      OPEN (UNIT = nulin,FILE ='namcouple',STATUS='OLD',
+     $      FORM ='FORMATTED',ERR = 210,IOSTAT = iost)
+      CALL prtout 
+     $    ('Open input file namcouple connected to unit ',nulin,1)
+ 210  CONTINUE
+      IF (iost .ne. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***' 
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' ===>>> : ERROR opening input  FILE'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' ======   =====                ===='
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Logical unit ',nulin,' error number = ',iost
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' We STOP!!! Verify the file namcouple'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL HALTE ('STOP in couple')
+      ENDIF
+C
+C
+C*    3. Launch the run by calling the simulation driver
+C        -----------------------------------------------
+C
+      CALL driver
+C
+C
+C*    4. End of the fun
+C        --------------
+C
+      WRITE(nulou, *) 'END of Oasis'
+      CLOSE(nulin)
+      CLOSE(nulou)
+      STOP 'END OF OASIS SIMULATION'
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/dealloc.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/dealloc.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/dealloc.f90	(revision 1677)
@@ -0,0 +1,101 @@
+SUBROUTINE dealloc
+!
+!**** DEALLOC
+!
+!     Purpose:
+!       Deallocate arrays defined in the modules
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "inialloc".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_parameter
+!
+!*-----------------------------------------------------------------------
+  IF (lg_oasis_field) THEN 
+!
+!** + Module anais
+!
+   CALL dealloc_anais
+!
+!** + Module analysis
+!
+   CALL dealloc_analysis
+!
+!** + Module coast
+!
+   CALL dealloc_coast
+!
+!** + Module extrapol
+!
+   CALL dealloc_extrapol 
+!
+!** + Module memory
+!
+   CALL dealloc_memory
+!
+!** + Module nproc
+!
+   CALL dealloc_nproc
+!
+!** + Module parallel
+!
+   CALL dealloc_parallel
+!
+!** + Module pipe
+!
+   CALL dealloc_pipe
+!
+!** + Module rainbow
+!
+   CALL dealloc_rainbow
+!
+!** + Module sipc
+!
+   CALL dealloc_sipc
+!
+!** + Module timestep
+!
+   CALL dealloc_timestep
+!
+!** + Module unitncdf
+!
+   CALL dealloc_unitncdf
+
+ENDIF
+!
+!** + Module experiment
+!
+CALL dealloc_experiment
+!
+!** + Module string
+!
+CALL dealloc_string
+!
+!*------------------------------------------------------------------------
+!
+END SUBROUTINE dealloc
+!
+!*========================================================================
Index: CPL/oasis3/trunk/src/mod/oasis3/src/dealloc_src.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/dealloc_src.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/dealloc_src.f90	(revision 1677)
@@ -0,0 +1,797 @@
+!                       ****************************
+!                       * DEALLOCATION SUBROUTINES *
+!                       ****************************
+SUBROUTINE dealloc_anais
+!
+!**** DEALLOC_ANAIS
+!
+!     Purpose:
+!       Deallocate arrays defined in the "anais" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_anais" or "inipar_alloc"
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_kinds_oasis
+  USE mod_anais
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: il_err
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (varmul, stat=il_err)
+  DEALLOCATE (niwtm)
+  DEALLOCATE (niwtg)
+  DEALLOCATE (linit)
+  DEALLOCATE (ngint)
+  DEALLOCATE (nmint)
+  DEALLOCATE (nmesh)
+  DEALLOCATE (agint)
+  DEALLOCATE (amint)
+  IF (allocated(naismfl)) DEALLOCATE (naismfl)
+  IF (allocated(naismvoi)) DEALLOCATE (naismvoi)
+  IF (allocated(naisgfl)) DEALLOCATE (naisgfl)
+  IF (allocated(naisgvoi)) DEALLOCATE (naisgvoi)
+  
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_anais
+!
+!*========================================================================
+SUBROUTINE dealloc_analysis
+!
+!**** DEALLOC_ANALYSIS
+!
+!     Purpose:
+!       Deallocate arrays defined in the "analysis" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_analysis".     
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_analysis
+!
+!*-----------------------------------------------------------------------
+!
+  IF (allocated(ntronca)) DEALLOCATE (ntronca)
+  DEALLOCATE (ncofld)
+  DEALLOCATE (neighborg)
+  DEALLOCATE (nludat)
+  DEALLOCATE (nlufil)
+  DEALLOCATE (nlumap)
+  DEALLOCATE (nlusub)
+  DEALLOCATE (nluext)
+  DEALLOCATE (nosper)
+  DEALLOCATE (notper)
+  DEALLOCATE (ntinpflx)
+  DEALLOCATE (ntoutflx)
+  DEALLOCATE (amskval)
+  DEALLOCATE (amskvalnew)
+  DEALLOCATE (acocoef)
+  DEALLOCATE (abocoef)
+  DEALLOCATE (abncoef)
+  DEALLOCATE (afldcoef)
+  DEALLOCATE (afldcobo)
+  DEALLOCATE (afldcobn)
+  DEALLOCATE (cxordbf)
+  DEALLOCATE (cyordbf)
+  DEALLOCATE (cxordaf)
+  DEALLOCATE (cyordaf)
+  DEALLOCATE (cgrdtyp)
+  DEALLOCATE (cfldtyp)
+  DEALLOCATE (cfilfic)
+  DEALLOCATE (cfilmet)
+  DEALLOCATE (cconmet)
+  DEALLOCATE (cfldcoa)
+  DEALLOCATE (cfldfin)
+  DEALLOCATE (ccofld)
+  DEALLOCATE (cbofld)
+  DEALLOCATE (cbnfld)
+  DEALLOCATE (ccofic)
+  DEALLOCATE (cdqdt)
+  DEALLOCATE (cgrdmap)
+  DEALLOCATE (cmskrd)
+  DEALLOCATE (cgrdsub)
+  DEALLOCATE (ctypsub)
+  DEALLOCATE (cgrdext)
+  DEALLOCATE (csper)
+  DEALLOCATE (ctper)
+  DEALLOCATE (lsurf)
+  DEALLOCATE (nscripvoi)
+  DEALLOCATE (cmap_method)
+  DEALLOCATE (cfldtype)
+  DEALLOCATE (crsttype)
+  DEALLOCATE (nbins)
+  DEALLOCATE (cnorm_opt)
+  DEALLOCATE (corder)
+!* Vector case
+  IF (lg_vector) THEN
+      DEALLOCATE (cg_assoc_input_field)
+      DEALLOCATE (ig_assoc_input_field)
+      DEALLOCATE (lrotate)
+  ENDIF
+!
+  IF (allocated(cintmet)) DEALLOCATE(cintmet)
+  IF (allocated(cextmet)) DEALLOCATE(cextmet)
+  IF (allocated(neighbor)) DEALLOCATE(neighbor)
+  IF (allocated(nextfl)) DEALLOCATE(nextfl)
+  IF (allocated(nbofld)) DEALLOCATE(nbofld)
+  IF (allocated(nbnfld)) DEALLOCATE(nbnfld)
+  IF (allocated(nmapvoi)) DEALLOCATE(nmapvoi)
+  IF (allocated(nmapfl)) DEALLOCATE(nmapfl)
+  IF (allocated(nsubfl)) DEALLOCATE(nsubfl)
+  IF (allocated(nsubvoi)) DEALLOCATE(nsubvoi)
+  
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_analysis
+!
+!*========================================================================
+SUBROUTINE dealloc_coast
+!
+!**** DEALLOC_COAST
+!
+!     Purpose:
+!       Deallocate arrays defined in the "coast" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_coast".     
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+
+
+  USE mod_coast
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (npcoast)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_coast
+!
+!*========================================================================
+SUBROUTINE dealloc_experiment
+!
+!**** DEALLOC_EXPERIMENT
+!
+!     Purpose:
+!       Deallocate arrays defined in the "experiment" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_experiment".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_experiment
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (nbcplproc)
+  DEALLOCATE (nbtotproc)
+  DEALLOCATE (cmodnam)
+  DEALLOCATE (cmpiarg)
+  DEALLOCATE (iga_unitmod)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_experiment
+!
+!*========================================================================
+SUBROUTINE dealloc_extrapol
+!
+!**** DEALLOC_EXTRAPOL
+!
+!     Purpose:
+!       Deallocate arrays defined in the "extrapol" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_extrapol".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_extrapol
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (niwtn)
+  DEALLOCATE (niwtng)
+  IF (allocated(nninnfl)) DEALLOCATE(nninnfl)
+  IF (allocated(nninnflg)) DEALLOCATE (nninnflg)
+  DEALLOCATE (lextra)
+  DEALLOCATE (lweight)
+  DEALLOCATE (aextra)
+  DEALLOCATE (nextra)
+  DEALLOCATE (lextrapdone)
+  IF (allocated(iaddress)) DEALLOCATE (iaddress)
+  IF (allocated(iincre)) DEALLOCATE (iincre)
+  IF (allocated(zweights)) DEALLOCATE (zweights)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_extrapol
+!
+!*========================================================================
+SUBROUTINE dealloc_memory
+!
+!**** DEALLOC_MEMORY
+!
+!     Purpose:
+!       Deallocate arrays defined in the "memory" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_memory".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_memory
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (nsizold)
+  DEALLOCATE (nsiznew)
+  DEALLOCATE (nadrold)
+  DEALLOCATE (nadrold_grid)
+  DEALLOCATE (nadrnew)
+  DEALLOCATE (nadrnew_grid)
+  DEALLOCATE (mskold)
+  DEALLOCATE (msknew)
+  DEALLOCATE (fldold)
+  DEALLOCATE (xgrold)
+  DEALLOCATE (ygrold)
+  DEALLOCATE (surold)
+  DEALLOCATE (fldnew)
+  DEALLOCATE (xgrnew)
+  DEALLOCATE (ygrnew)
+  DEALLOCATE (surnew)
+  DEALLOCATE (nwork)
+  DEALLOCATE (work)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_memory
+!
+!*========================================================================
+SUBROUTINE dealloc_nproc
+!
+!**** DEALLOC_NPROC
+!
+!     Purpose:
+!       Deallocate arrays defined in the "nproc" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_nproc".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_nproc
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (nproc)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_nproc
+!
+!*========================================================================
+SUBROUTINE dealloc_parallel
+!
+!**** DEALLOC_ANALYSIS
+!
+!     Purpose:
+!       Deallocate arrays defined in the "parallel" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_parallel".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_parallel
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (nparal)
+  DEALLOCATE (cparal)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_parallel
+!
+!*========================================================================
+SUBROUTINE dealloc_pipe
+!
+!**** DEALLOC_PIPE
+!
+!     Purpose:
+!       Deallocate arrays defined in the "pipe" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_pipe".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_pipe
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (cprnam)
+  DEALLOCATE (cpwnam)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_pipe
+!
+!*========================================================================
+SUBROUTINE dealloc_rainbow
+!
+!**** DEALLOC_RAINBOW
+!
+!     Purpose:
+!       Deallocate arrays defined in the "rainbow" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_rainbow".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_rainbow
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (lmapp)
+  DEALLOCATE (lsubg)
+  DEALLOCATE (amapp)
+  DEALLOCATE (asubg)
+  DEALLOCATE (nmapp)
+  DEALLOCATE (nsubg)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_rainbow
+!
+!*========================================================================
+SUBROUTINE dealloc_sipc
+!
+!**** DEALLOC_SIPC
+!
+!     Purpose:
+!       Deallocate arrays defined in the "sipc" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_sipc".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_sipc
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (mpoolidin)
+  DEALLOCATE (mpoolidou)
+  DEALLOCATE (mpoolinitr)
+  DEALLOCATE (mpoolinitw)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_sipc
+!
+!*========================================================================
+SUBROUTINE dealloc_string
+!
+!**** DEALLOC_SIPC
+!
+!     Purpose:
+!       Deallocate arrays defined in the "string" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_string".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_string
+  USE mod_parameter
+!
+!*-----------------------------------------------------------------------
+!
+  IF (lg_oasis_field) THEN 
+     DEALLOCATE (numlab)
+     DEALLOCATE (nfexch)
+     DEALLOCATE (nluinp)
+     DEALLOCATE (nluout)
+     DEALLOCATE (nseqn)
+     DEALLOCATE (nlagn)
+     DEALLOCATE (cnaminp)
+     DEALLOCATE (cnamout)
+     DEALLOCATE (cficinp)
+     DEALLOCATE (cficout)
+     DEALLOCATE (cstate)
+     DEALLOCATE (ig_portin_id)
+     DEALLOCATE (ig_portout_id)
+     DEALLOCATE (cficbf)
+     DEALLOCATE (cficaf)
+     DEALLOCATE (nlonbf)
+     DEALLOCATE (nlatbf)
+     DEALLOCATE (nlonaf)
+     DEALLOCATE (nlataf)
+     DEALLOCATE (ig_ntrans)
+     DEALLOCATE (canal)
+     DEALLOCATE (ig_grid_nbrbf)
+     DEALLOCATE (ig_grid_nbraf)
+  ENDIF
+
+  DEALLOCATE (ig_lag)
+  DEALLOCATE (lg_state)
+  DEALLOCATE (ig_no_rstfile)
+  DEALLOCATE (cg_name_rstfile)
+  DEALLOCATE (ig_numlab)
+  DEALLOCATE (ig_freq)
+  DEALLOCATE (ig_total_nseqn)
+  DEALLOCATE (cg_input_field)
+  DEALLOCATE (cg_output_field)
+  DEALLOCATE (ig_total_state)
+  DEALLOCATE (ig_local_trans)
+  DEALLOCATE (cg_input_file)
+  DEALLOCATE (ig_number_field)
+  DEALLOCATE (ig_total_ntrans)
+  DEALLOCATE (cg_restart_file)
+  DEALLOCATE (cga_locatorbf)
+  DEALLOCATE (cga_locatoraf)
+  DEALLOCATE (ig_invert)
+  DEALLOCATE (ig_reverse)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_string
+!
+!*========================================================================
+SUBROUTINE dealloc_timestep
+!
+!**** DEALLOC_SIPC
+!
+!     Purpose:
+!       Deallocate arrays defined in the "timestep" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_timestep".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_timestep
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (mstep)
+  DEALLOCATE (mfcpl)
+  DEALLOCATE (mdt)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_timestep
+!
+!*========================================================================
+SUBROUTINE dealloc_unitncdf
+!
+!**** DEALLOC_UNITNCDF
+!
+!     Purpose:
+!       Deallocate arrays defined in the "unitncdf" module
+!
+!     Interface:
+!       none
+!    
+!     Method:
+!       Deallocation of arrays allocated in "alloc_unitncdf".       
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/03/18  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!** ++ Use of modules
+!
+  USE mod_unitncdf
+!
+!*-----------------------------------------------------------------------
+!
+  DEALLOCATE (nc_inpid)
+  DEALLOCATE (nc_outid)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE dealloc_unitncdf
+!
+!*========================================================================
Index: CPL/oasis3/trunk/src/mod/oasis3/src/driver.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/driver.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/driver.f	(revision 1677)
@@ -0,0 +1,294 @@
+      SUBROUTINE driver
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *driver* - Main OASIS routine
+C
+C
+C     Purpose:
+C     -------
+C     Drive and control the simulation between GCMs and coupler.
+C     Contain the time loop. A coupled simulation with OASIS 2.0
+C     starts with the interpolation of the boundary conditions
+C     from their original grid to the target grid in contrast with
+C     the previous versions. Consequently, the GCMs pause initially
+C     until the coupling variables have been interpolated.
+C
+C     N.B: Note that the time loop goes from 0 to niter-1 in contrast
+C          with previous versions. The iteration 0 of oasis DOES NOT
+C          increment the simulation time.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *driver*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C               iindex : index array for field identificators
+C
+C     Externals:
+C     ---------
+C                        Initialization
+C                        **************
+C     inipar, inilun, iniiof, inidya, initim, inicmc, chkpar, inigrd,
+C
+C                        Temporal loop
+C                        ************* 
+C     getfld, preproc, interp, cookart, postpro, givfld, reset, updtim
+C
+C                        Synchronization
+C                        ***************
+C     modsgc, waitpc
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0beta   L. Terray      95/07/24  modified: new structure
+C       2.0       L. Terray      96/02/01  modified: change in time loop
+C       2.1       O. Marti, L.T  96/09/25  added: extra time step
+C       2.2       S. Valcke, L.T 97/11/13  added: SIPC call to modsgc
+C                                                 mode no message passing
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* -----------------Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_parameter
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_unit
+      USE mod_hardware
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iindex
+      LOGICAL lltime, llseqn, llend
+      INTEGER (kind=ip_intwp_p) :: il_flag
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+C* - Initialize main run parameters
+C
+      CALL inipar_alloc
+C
+C* - "iindex" allocation
+C
+      IF (lg_oasis_field) THEN 
+         ALLOCATE(iindex(ig_nfield))
+         iindex(:)=0
+      ENDIF
+C
+C* - Allocate arrays (first round)
+C
+      il_flag=1
+      CALL alloc(il_flag)
+C
+C* - Initialize other run parameters
+C
+      CALL inipar  
+C
+C* - Initialize logical unit numbers
+C
+      CALL inilun
+cvg C
+cvg C* - Open necessary files
+cvg C
+cvg       CALL iniiof
+
+C
+C* - Initialize time information
+C
+      CALL initim
+C
+C* - Initialize communication between processes
+C
+      CALL inicmc
+C
+C* - Allocate arrays (second round)
+C
+      il_flag=2
+      CALL alloc(il_flag)
+C
+cvg>>>
+C
+C* - Set up dynamic allocation for all grid-related fields
+C
+      CALL inidya
+C
+C* - Open necessary files
+C
+      CALL iniiof
+cvg<<<
+
+C
+C* - Check run parameters compatibility between GCM's and coupler
+C
+      CALL chkpar
+C
+C* - Initialize GCM's grids
+C
+      CALL inigrd
+C
+C* - We will go through the next time loop only if one field (at least) goes
+C    through Oasis
+
+      IF (lg_oasis_field) THEN
+C
+C*    2. Time loop
+C        ---------
+C
+C* Loop on number of iterations
+C* First iteration takes place at ndate (INIDATE in namcouple) and
+C* last iteration at one timestep before the end of the simulation
+C* (INIDATE + RUNTIME in namcouple), 
+C
+         DO 210 jt = 0, nitfn
+C
+C* Assign local variable for iteration number
+C
+            iter = jt
+C
+C* Get time counter. 
+C
+            icount = iter * nstep
+C
+C* Update calendar date
+C
+            CALL updtim (iter)
+C
+C* Loop on number of sequential models
+C
+            DO 220 jm = 1, nmseq
+C
+C* Loop on number of fields to find active fields for current iteration
+C
+               ifield = 0
+               DO 230 jf = 1, ig_total_nfield
+C
+C* Treat the field only IF it has to go through Oasis
+C
+                  IF (lg_state(jf)) THEN
+C     
+C* Get conditional logical flags for doing analysis set
+C
+C
+C* Treat the field only if time smaller than end of simulation
+                     llend  = icount .LT. ntime
+C
+C* Treat the field only if iteration corresponds to one 
+C* of its coupling timesteps
+                     ifnow = nfexch(ig_number_field(jf))
+                     lltime = mod(icount,ifnow) .EQ. 0
+C
+C* If sequential order, treat the field only if it is consumed
+C* in present loop
+                     llseqn = nseqn(ig_number_field(jf)) .EQ. jm
+C
+C* Conditional test to fill up iindex array
+C
+                     IF (llseqn .AND. lltime .AND. llend) 
+     $                    THEN
+                        ifield = ifield + 1
+C
+C* Fill up iindex array with active fields at iteration jt
+C
+                        iindex(ifield) = ig_number_field(jf)
+                     ENDIF
+                  ENDIF
+ 230           CONTINUE
+C
+C* There are ifield fields to be exchanged for iteration jt
+C
+               IF (ifield .GT. 0) THEN
+C
+C* Get fields
+C
+                  CALL getfld (iindex, ifield, iter)
+C
+C* Do preprocessing
+C
+                  CALL preproc (iindex, ifield)
+C
+C* Do the interpolation
+C
+                  CALL interp (iindex, ifield)
+C
+C* Do the nitty gritty stuff
+
+C
+                  CALL cookart (iindex, ifield)
+C
+C* Do postprocessing
+C
+                  CALL postpro (iindex, ifield)
+C
+C* If last iteration in PIPE or SIPC case, switch sigcld handler
+                  IF (iter .EQ. nitfn) THEN
+                     IF (cchan .EQ. 'PIPE' .OR. cchan .EQ. 'SIPC')
+     $                    CALL modsgc
+                  ENDIF
+C
+C* Give back fields
+C     
+                  CALL givfld (iindex, ifield, iter)
+               ENDIF
+C
+C* End of loop over the sequential models
+C
+ 220        CONTINUE
+C
+C* Reset macro arrays
+C
+        CALL reset
+C
+C* End of iterative loop
+C
+ 210  CONTINUE
+      ENDIF
+C
+C*    3. Wait until end of child processes
+C        ---------------------------------
+C
+      CALL waitpc
+C
+C
+C*    4. End of routine
+C        --------------
+C
+C* "iindex" deallocation
+C
+      IF (lg_oasis_field) DEALLOCATE(iindex)
+C
+C* Deallocation of arrays allocated in "inialloc" routine      
+C
+      CALL dealloc
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/empty.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/empty.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/empty.f	(revision 1677)
@@ -0,0 +1,76 @@
+      SUBROUTINE empty (cdchar, klen)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *empty*  - Utility routine
+C
+C     Purpose:
+C     -------
+C     Fill up a character string with blanks
+C
+C**   Interface:
+C     ---------
+C       *call*  *empty (cdchar, klen)*
+C
+C     Input:
+C     -----
+C                cdchar : string to be filled up with blanks (char string)
+C                klen   : string length (integer)
+C
+C     Output:
+C     ------
+C                cdchar : string filled up with blanks
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      CHARACTER*1 cdchar
+      DIMENSION cdchar(klen)
+C
+C* ---------------------------- Local declarations -------------------
+C
+      CHARACTER (len=1), SAVE :: clblank = ' '
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Fill s1 with blanks
+C        -------------------
+C
+      DO 110 ji = 1, klen
+        cdchar(ji) = clblank
+ 110  CONTINUE
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/extrap.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/extrap.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/extrap.F	(revision 1677)
@@ -0,0 +1,588 @@
+      SUBROUTINE extrap (pfild, pmask, pwork, 
+     $                   kmask, kxlon, kylat, 
+     $                   knbor, cdextmet, cdper, kper, 
+     $                   krdwt, knb)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *extrap* - Extrapolation routine
+C
+C     Purpose:
+C     -------
+C     Extrapolate field on land from sea values using nearest 
+C     neighbors filling.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *extrap (pfild, pmask, pwork, 
+C    $                   kmask, kxlon, kylat,
+C    $                   knbor, cdextmet, cdper, kper, 
+C    $                   krdwt, knb)
+C
+C     Input:
+C     -----
+C                pfild    : field to be extrapolated (real 2D)
+C                pmask    : mask value (real)
+C                pwork    : work array (real 2D)
+C                kmask    : mask array (integer 2D)
+C                kxlon    : number of longitudes (integer)
+C                kylat    : number of latitudes (integer)
+C                knbor    : nbr of neighbors for extrapolation (integer)
+C                cdextmet : extrapolation method (character)
+C                cdper    : grid period.:P-period.,R-region. (character)
+C                kper     : number of overlapping grid points (if any)
+C                krdwt    : read/write flag for the weights and address
+C                knb  : flag to identify appropriate NINENN dataset
+C
+C     Output:
+C     ------
+C                pfild    : field extrapolated
+C
+C     Workspace:
+C     ---------
+C     zwork, zmask, ix, iy
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1998)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/12/20  modified: new structure
+C       2.2       L. Terray      97/12/31  modified: general cleaning
+C       2.3       L. Terray      99/03/01  corrected: bug with 
+C                                          latitudes fully masked
+C       2.3       S. Valcke      99/03/30  add READ/WRITE for NINENN 
+C                                          weights
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       S. Valcke      99/10/01  corrected: perodic 
+C                                          overlapping grid
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C 
+      USE mod_kinds_oasis
+      USE mod_parameter      
+      USE mod_extrapol
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(kxlon,kylat), pwork(kxlon,kylat)
+      INTEGER (kind=ip_intwp_p) kmask(kxlon,kylat), kper
+      CHARACTER*8 cdextmet, cdper
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL (kind=ip_realwp_p) zmask(9)
+      INTEGER (kind=ip_intwp_p) ix(9), iy(9)
+#ifdef key_openmp
+C     TS CHECK FOR EXISTENCE OF WEIGTH FILE
+      INTEGER (kind=ip_intwp_p) ::  access, status
+#endif
+      CHARACTER*8 cladress, clweight, clincrem
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization and allocation of local arrays
+C        ---------------------------------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE extrap  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Extrapolation on land with sea values'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      incre = 0
+      zmask(:)=0
+      ix(:)=0
+      iy(:)=0
+C
+      IF (.not.allocated(iaddress)) THEN
+          ALLOCATE (iaddress(ig_maxnfn,9,ig_maxgrd),stat=il_err)
+          IF (il_err.NE.0)  CALL prtout
+     $    ('Error in "iaddress" allocation of extrap ',il_err,1)
+          iaddress(:,:,:)=0
+      ENDIF
+      IF (.not.allocated(iincre)) THEN
+          ALLOCATE (iincre(ig_maxnfn,ig_maxgrd),stat=il_err)
+          IF (il_err.NE.0) CALL prtout ('Error in iincre 
+     $        allocation of extrap ',il_err,1)
+          iincre(:,:)=0
+      ENDIF
+      IF (.not.allocated(zweights)) THEN
+          ALLOCATE (zweights(ig_maxnfn,9,ig_maxgrd),stat=il_err)
+          IF (il_err.NE.0) CALL prtout ('Error in "zweights" 
+     $        allocation of extrap ',il_err,1)
+          zweights(:,:,:)=0
+      ENDIF
+C
+C* To avoid problems in floating point tests
+C
+      zwmsk = ABS(pmask) - 1.0
+C
+C
+C*    2. Calculating weights and filling masked values 
+C        ---------------------------------------------
+C
+      IF (cdextmet .EQ. 'NINENN') THEN
+          IF (nlogprt .GE. 2) THEN          
+              CALL prtout
+     $        ('NINENN Dataset number for this field is:',knb,1)
+          ENDIF
+C
+C* Define locators
+C
+          WRITE(clweight,'(''WEIGHTS'',I1)') knb
+          WRITE(cladress,'(''ADRESSE'',I1)') knb
+          WRITE(clincrem,'(''INCREME'',I1)') knb
+C
+C
+#ifdef key_openmp
+          status=0
+          status = access ( 'nweights', ' ' )
+          if ( status .eq. 0 ) write(*,*) "file exists in extrap"
+          if ( status .ne. 0 ) write(*,*) 'no such file', status
+          IF (status.ne.0 .AND. .NOT. lweight(knb)) THEN
+#else
+          IF (krdwt .EQ. 1 .AND. .NOT. lweight(knb)) THEN
+#endif
+C
+C* For krdwt=1, the weights and addresses are calculated by Oasis
+C
+C* Initialize iteration number, weight and address variables to zero
+              DO 201 jj = 1, kylat
+                DO 202 ji = 1, kxlon
+                  iind=(jj-1)*kxlon + ji
+                  iincre(knb,iind) = 0
+                  DO 203 jl = 1, 9
+                    iaddress(knb,jl, iind) = 0
+                    zweights(knb,jl, iind) = 0.
+ 203              CONTINUE
+ 202            CONTINUE
+ 201          CONTINUE
+C
+ 200          CONTINUE
+              incre = incre + 1
+              IF (incre .gt. 5000) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in extrap.f'
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'Number of iteration greater than 5000'
+                  CALL HALTE ('Stop in extrap')
+              ENDIF
+C
+!$omp parallel do default (shared)
+!$omp+ private (jj)
+              DO 210 jj = 1, kylat
+C
+C* Test if latitude 1 or kylat or n and n+1 are fully masked 
+C
+                iinf = iminim (kmask(1, jj),kxlon)
+                IF (jj .eq. 1 .OR. jj .eq. kylat) THEN
+                    isup=iinf
+                ELSE
+                    isup = iminim (kmask(1, jj+1),kxlon)
+                ENDIF
+C
+C* If yes, set number of neighbors to 3
+C
+                IF (iinf .EQ. 1 .AND. isup .EQ. 1) THEN
+                    ivoisin = MIN0(3,knbor)
+                ELSE 
+                    ivoisin = knbor
+                ENDIF 
+                DO 220 ji = 1, kxlon
+                  iind=(jj-1)*kxlon + ji
+                  pwork(ji,jj) = pfild(ji,jj)
+C
+C* Case 1:  value is not masked
+C
+                  IF (ABS(pfild(ji,jj)) .LT. zwmsk) THEN
+                      GOTO 220
+                  ELSE
+C
+C* Case 2:  value at point P is masked
+C
+C
+C  We search over the eight closest neighbors
+C
+C            j+1  7  8  9
+C              j  4  5  6    Current point 5 --> (i,j)
+C            j-1  1  2  3
+C
+C                i-1 i i+1 
+C  ix and iy are index arrays for the neighbors coordinates
+C
+                      inbor = 0
+                      ideb = 1
+                      ifin = 9
+C
+C* Fill up ix array
+C
+                      ix(1) = MAX0 (1,ji - 1)
+                      ix(2) = ji
+                      ix(3) = MIN0 (kxlon,ji + 1)
+                      ix(4) = MAX0 (1,ji - 1)
+                      ix(5) = ji
+                      ix(6) = MIN0 (kxlon,ji + 1)
+                      ix(7) = MAX0 (1,ji - 1)
+                      ix(8) = ji
+                      ix(9) = MIN0 (kxlon,ji + 1)
+C
+C* Fill up iy array
+C
+                      iy(1) = MAX0 (1,jj - 1)
+                      iy(2) = MAX0 (1,jj - 1)
+                      iy(3) = MAX0 (1,jj - 1)
+                      iy(4) = jj
+                      iy(5) = jj
+                      iy(6) = jj
+                      iy(7) = MIN0 (kylat,jj + 1)
+                      iy(8) = MIN0 (kylat,jj + 1)
+                      iy(9) = MIN0 (kylat,jj + 1)
+C
+C* Account for periodicity in longitude
+C
+                      IF (cdper .EQ. 'P') THEN
+                          IF (ji .EQ. kxlon) THEN
+                              ix(3) = 1 + kper
+                              ix(6) = 1 + kper
+                              ix(9) = 1 + kper
+                          ELSE IF (ji .EQ. 1) THEN
+                              ix(1) = kxlon - kper
+                              ix(4) = kxlon - kper
+                              ix(7) = kxlon - kper
+                          ELSE 
+                              CONTINUE 
+                          ENDIF
+                      ENDIF
+C
+C* Correct latitude bounds if southernmost or northernmost points
+C
+                      IF (jj .EQ. 1) ideb = 4
+                      IF (jj .EQ. kylat) ifin = 6
+C
+C* Grid not periodic 
+C
+                          IF (cdper .EQ. 'R') THEN
+C* ji = 1
+                          IF (ji .EQ. 1) THEN
+                              ix(1) = ji
+                              ix(2) = ji + 1
+                              ix(3) = ji
+                              ix(4) = ji + 1
+                              ix(5) = ji
+                              ix(6) = ji + 1
+                          ENDIF 
+C* ji = kxlon
+                          IF (ji .EQ. kxlon) THEN
+                              ix(1) = ji -1
+                              ix(2) = ji
+                              ix(3) = ji - 1
+                              ix(4) = ji
+                              ix(5) = ji - 1
+                              ix(6) = ji
+                          ENDIF
+C
+C* Latitude index in both cases
+C
+                          IF (ji .EQ. 1 .OR. ji .EQ. kxlon) THEN 
+                              ideb = 1
+                              ifin = 6
+                              iy(1) = MAX0 (1,jj - 1)
+                              iy(2) = MAX0 (1,jj - 1)
+                              iy(3) = jj
+                              iy(4) = jj
+                              iy(5) = MIN0(kylat,jj + 1)
+                              iy(6) = MIN0(kylat,jj + 1)
+C
+C* Correct latitude bounds if southernmost or northernmost points
+C
+                              IF (jj .EQ. 1) ideb = 3
+                              IF (jj .EQ. kylat) ifin = 4
+                          ENDIF
+                      ENDIF 
+C
+C* Find unmasked neighbors
+C
+                      DO 230 jl = ideb, ifin
+                        zmask(jl) = 0.
+                        ilon = ix(jl)
+                        ilat = iy(jl)
+                        IF (ABS(pfild(ilon,ilat)) .LT. zwmsk) THEN
+                            zmask(jl) = 1.
+                            inbor = inbor + 1
+                        ENDIF
+ 230                  CONTINUE
+C
+C* Not enough points around point P are unmasked; interpolation on P 
+C  will be done in a future call to extrap.
+C
+                      IF (inbor .LT. ivoisin) THEN
+                          GOTO 220
+                      ELSE
+C
+C* Some points around P are not masked so we use them to extrapolate
+C* and define the iteration number, weight and address variables
+C
+                          pwork(ji,jj) = 0.
+                          iincre(knb, iind) = incre
+                          DO 240 jl = ideb, ifin
+                           ilon = ix(jl)
+                           ilat = iy(jl)
+                           pwork(ji,jj) = pwork(ji,jj)
+     $                        + pfild(ilon,ilat) * zmask(jl)
+     $                        / FLOAT(inbor)
+                           iaddress(knb,jl,iind)=(ilat-1)*kxlon+ilon
+                           zweights(knb,jl,iind)=zmask(jl)/FLOAT(inbor)
+ 240                      CONTINUE
+C
+                      ENDIF
+                  ENDIF
+ 220            CONTINUE
+ 210          CONTINUE
+C
+C*    3. Writing back unmasked field in pfild and writing weights to file
+C        ----------------------------------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+              idoit = 0
+              DO 310 jj = 1, kylat
+                DO 320 ji = 1, kxlon
+                  IF (ABS(pwork(ji,jj)) .GT. zwmsk) THEN
+                      idoit = idoit + 1
+                  ENDIF
+                  pfild(ji,jj) = pwork(ji,jj)
+ 320            CONTINUE
+ 310          CONTINUE
+C
+              IF (idoit .ne. 0) GOTO 200
+C
+C* Write weights, addresses and iteration numbers in file
+C
+C* Weights
+#ifdef key_openmp
+C  OPEN statement removed from iniiof
+C  This is to check the existence of weights file in extrap
+
+         OPEN (UNIT = nulgn,FILE = cwninenn,
+     $        FORM ='UNFORMATTED',ERR = 340,IOSTAT = iost)
+ 340     CONTINUE
+#endif
+C
+              CALL locwrite (clweight, zweights, ig_maxnfn*9*kxlon*
+     $            kylat, nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+                  CALL HALTE ('Stop in extrap writing weights')
+              ENDIF
+C 
+C* Adresses
+C
+              CALL locwrint (cladress, iaddress, ig_maxnfn*9*kxlon*
+     $            kylat, nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+                  CALL HALTE ('Stop in extrap writing addresses')
+              ENDIF
+C
+C* Iteration numbers
+C
+              CALL locwrint (clincrem, iincre, ig_maxnfn*kxlon*kylat,
+     $                   nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in writing on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clincrem
+                  CALL HALTE ('Stop in extrap writing iteration number')
+              ENDIF
+C
+C* Printing
+C
+              IF (nlogprt .GE. 2) THEN
+                 CALL prtout
+     $   ('Wrote weights,addresses and iteration numbers on unit = ', 
+     $     nulgn, 1)
+              ENDIF
+          ENDIF
+C
+#ifdef key_openmp
+          IF ( .NOT. lweight(knb)) THEN
+#else
+          IF (krdwt .EQ. 0 .AND. .NOT. lweight(knb)) THEN
+#endif
+C
+C
+C*    4. Reading weights and filling masked values 
+C        ---------------------------------------------
+C
+C* For krdwt=0, the weights, addresses and iteration numbers are read by Oasis
+C
+              CALL locread (clweight, zweights, ig_maxnfn*9*kxlon*
+     $            kylat, nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clweight
+                  CALL HALTE ('Stop in extrap reading weights')
+              ENDIF
+C
+              CALL locrint (cladress, iaddress, ig_maxnfn*9*kxlon*
+     $            kylat, nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', cladress
+                  CALL HALTE ('Stop in extrap reading addresses')
+              ENDIF
+C
+              CALL locrint (clincrem, iincre, ig_maxnfn*kxlon*kylat,
+     $                   nulgn, iflag)
+              IF (iflag .NE. 0) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $            'Problem in reading on UNIT = ', nulgn
+                  WRITE (UNIT = nulou,FMT = *)
+     $            'String locator is = ', clincrem
+                  CALL HALTE('Stop in extrap reading iteration numbers')
+              ENDIF
+          ENDIF
+C
+C* Extrapolation
+C
+#ifdef key_openmp
+          IF ( lweight(knb)) THEN
+#else
+           IF (krdwt .EQ. 0 .OR. lweight(knb)) THEN
+#endif
+cvg>>>
+              idoitold = 1000000
+cvg<<<
+ 400          CONTINUE
+
+              incre = incre + 1
+              DO 410 jj = 1, kylat
+                DO 420 ji = 1, kxlon
+                  iind=(jj-1)*kxlon + ji
+                  pwork(ji,jj) = pfild(ji,jj)
+C
+C* Case 1:  value is not masked
+C
+                  IF (ABS(pfild(ji,jj)) .LT. zwmsk) THEN
+                      GOTO 420
+                    ELSE
+C
+C* Case 2:  value at point P is masked
+C
+                      IF (iincre(knb,iind) .EQ. incre) THEN
+                          pwork(ji,jj) = 0.
+                          DO 250 jl = 1,9
+                            IF (zweights(knb,jl,iind).EQ.0.) GO TO 250
+                            idivi=iaddress(knb, jl, iind)/kxlon
+                            imult=idivi*kxlon
+                            IF (iaddress(knb,jl, iind) .EQ. imult) THEN
+                                ilat=idivi
+                                ilon=kxlon
+                              ELSE
+                                ilat=idivi+1
+                                ilon=iaddress(knb,jl, iind)-imult
+                            ENDIF
+                            pwork(ji,jj) = pwork(ji,jj)
+     $                          + pfild(ilon,ilat)
+     $                          *zweights(knb,jl,iind)
+ 250                      CONTINUE
+                      ENDIF
+                  ENDIF
+ 420            CONTINUE
+ 410          CONTINUE
+
+C
+C*    5. Writing back unmasked field in pfild
+C        ------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+              idoit = 0
+              DO 510 jj = 1, kylat
+                DO 520 ji = 1, kxlon
+                  IF (ABS(pwork(ji,jj)) .GT. zwmsk) THEN
+                      idoit = idoit + 1
+                  ENDIF
+                  pfild(ji,jj) = pwork(ji,jj)
+ 520            CONTINUE
+ 510          CONTINUE
+cvg>>>
+              IF (idoit .eq. idoitold) THEN
+                 WRITE (UNIT = nulou,FMT = *) 
+     $               'extrap: nweights does not fit to your masks file'
+                 WRITE (UNIT = nulou,FMT = *) 
+     $               'extrap: create new file nweights ',
+     $               '($NIO = 1 in namcouple)'
+                 CALL HALTE ('Stop in extrap: no progress in iteration')
+              ENDIF
+              idoitold = idoit
+cvg<<<
+              IF (idoit .ne. 0) GOTO 400
+          ENDIF
+C
+C* Printing
+C
+          IF (nlogprt .GE. 2) THEN
+              CALL prtout
+     $        ('Number of extrapolation steps incre =', incre, 1)
+              CALL FLUSH(nulou)
+          ENDIF
+      ENDIF 
+C
+C* Put flag indicating that weights have been read or calculated to 1
+C
+      lweight(knb)= .TRUE.
+C
+C*    4. End of routine 
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine extrap ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/extraw.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/extraw.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/extraw.f	(revision 1677)
@@ -0,0 +1,182 @@
+      SUBROUTINE extraw (pfild, kmask, ksize,
+     $                   cdfic, kunit, cdgrd, knumb,
+     $                   pwork, kwork, knbor, ldread)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *extraw* - Weighted extrapolation
+C
+C     Purpose:
+C     -------
+C     Do simple weighted extrapolation to replace land point values
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *extraw (pfild, kmask, ksize, cdfic, kunit,
+C                        cdgrd. knumb, pwork, kwork, knbor, ldread)*
+C
+C     Input:
+C     -----
+C                pfild  : field on source grid (real 1D)
+C                kmask  : land-sea mask on source grid (integer 1D)
+C                ksize  : size of field array on source grid (integer)
+C                kunit  : logical unit number for extrapolation file (integer)
+C                cdfic  : filename for extrapolation data (character)
+C                cdgrd  : locator to read  data in cdfic (character)
+C                knumb  : extrapolation dataset identity number (integer)
+C                pwork  : temporary array to read weights (real 2D)
+C                kwork  : temporary array to read adresses (integer 2D)
+C                knbor  : maximum number of source grid neighbors with non zero
+C                         weights  with a source grid-square (integer)
+C                ldread : logical flag to read extrapolation data
+C
+C     Output:
+C     ------
+C                pfild  : field on source grid (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     locrint, locread
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       L. Terray      97/12/16  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(ksize), pwork(knbor,ksize)
+      INTEGER (kind=ip_intwp_p) kwork(knbor,ksize), kmask(ksize)
+      CHARACTER*8 cdfic, cdgrd
+      LOGICAL ldread
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clweight, cladress
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE extraw  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' weighted extrapolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* initialize error flag for I/O routine
+C
+      iflag = 0
+C
+C
+C*    2. Read extrapolation data the first time
+C        --------------------------------------
+C
+      IF (ldread) THEN 
+C
+C* Initialize locators and array sizes
+C
+          WRITE(clweight,'(''WEIGHTS'',I1)') knumb
+          WRITE(cladress,'(''ADRESSE'',I1)') knumb
+          isize = ksize * knbor
+C
+C* Adress of connected points on source grid
+C
+          CALL locrint (cladress, kwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading mapping data',
+     $            cdgrd, 1)
+              CALL prcout
+     $            ('Could not get adress array', cladress, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in extraw') 
+          ENDIF
+C
+C* Weights of overlapped points on source grid
+C
+          CALL locread (clweight, pwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading mapping data',
+     $            cdgrd, 1)
+              CALL prcout
+     $            ('Could not get weight array', clweight, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in extraw') 
+          ENDIF
+          ldread = .FALSE. 
+      ENDIF 
+C
+C
+C*    3. Do the mapping interpolation
+C        ----------------------------
+C
+C* Loop on all the target grid points
+C
+      DO 310 ji = 1, ksize
+C* If it is a land point, we extrapolate
+        IF (kmask(ji) .EQ. 1) THEN 
+            zsum = 0.
+            DO 320 jk = 1, knbor
+              zsum = zsum + pwork(jk,ji) * pfild(kwork(jk,ji))
+ 320        CONTINUE 
+            pfild(ji) = zsum
+        ENDIF 
+ 310  CONTINUE
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine extraw ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/ferror.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/ferror.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/ferror.F	(revision 1677)
@@ -0,0 +1,174 @@
+      SUBROUTINE ferror
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *ferror*  - Signal handler
+C
+C     Purpose:
+C     -------
+C     ferror is executed each time signal sigcld is caught.
+C     It stops execution of run due to child process death.
+C
+C**   Interface:
+C     ---------
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     wait, waitcld
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/12/20  modified: new structure
+C       2.2       L. Terray      97/10/10  added: Include nproc.h
+C       2.2       S. Valcke, L.T 97/12/24  added: call wait and waitcld 
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C       2.5       S. Valcke      2K/09/04  Remove cmach
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and use of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_experiment
+      USE mod_parameter
+      USE mod_nproc
+      USE mod_unit
+      USE mod_hardware
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) wait
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Signal sigcld has been caught; check which process is dead
+C        ----------------------------------------------------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' ROUTINE ferror  -  Level C'
+      WRITE (UNIT = nulou,FMT = *) ' **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' Catch child process death'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+#ifdef use_comm_PIPE 
+          iwone = wait(isone)
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+          CALL waitcld (isone, iwone)
+#endif
+      DO 110 jm = 1, ig_nmodel
+        IF (iwone .EQ. nproc(jm)) THEN 
+            WRITE (UNIT = nulou,FMT = *) 
+     $          ' WARNING: sigcld has been caught by coupler'
+            WRITE (UNIT = nulou,FMT = *) 
+     $          ' =======  ======                    ======='
+            WRITE (UNIT = nulou,FMT = *) 
+     $          ' model ', cmodnam(jm), 
+     $          ' process pid = ',nproc(jm),' is dead'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $          ' We STOP the simulation now !!!'
+            WRITE (UNIT = nulou,FMT = *) ' '
+        ENDIF 
+ 110  CONTINUE 
+      CALL FLUSH (nulou)
+C
+C
+C*    2. End of simulation if abnormal termination
+C        -----------------------------------------
+C
+      CALL HALTE ('STOP in ferror')
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      RETURN
+      END
+      SUBROUTINE fignore
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *fignore*  - Signal handler
+C
+C     Purpose:
+C     -------
+C     fignore is executed each time signal sigcld is caught.
+C**   Interface:
+C     ---------
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C
+C     Reference:
+C     ---------
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.5       S. Valcke      01/08/02  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and use of modules-------------------   
+C
+      USE mod_unit
+C
+C* ---------------------------- Local declarations ----------------------
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' ROUTINE fignore -  Level C'
+      WRITE (UNIT = nulou,FMT = *) ' ***************    *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+C
+C*    End of routine
+C     --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/fiasco.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/fiasco.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/fiasco.f	(revision 1677)
@@ -0,0 +1,465 @@
+      SUBROUTINE fiasco (poutp, ptlon, ptlat, ptsurf,
+     $                   ktmsk, ktlon, ktlat, cdtper, ktper,
+     $                   pinpt, pslon, pslat, pssurf,
+     $                   ksmsk, kslon, kslat, cdsper, ksper,
+     $                   plonz, platz, psgrb, psgra, psfrb, psfra,
+     $                   kfield, cdint, cdtyp, cddim)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *fiasco* - Interpolation driver
+C
+C     Purpose:
+C     -------
+C     Interpolation from source grid to target grid
+C     Use Fast Scalar Interpolator (FSCINT) package from Yves Chartier
+C     or ANAIS software from Olivier Thual et al.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *fiasco* (poutp, ptlon, ptlat, ptsurf,
+C                         ktmsk, ktlon, ktlat, cdtper, ktper,
+C                         pinpt, pslon, pslat, pssurf,
+C                         ksmsk, kslon, kslat, cdsper, ksper,
+C                         plonz, platz, psgrb, psgra, psfrb, psfra,
+C                         kfield, cdint, cdtyp, cddim)*
+C
+C     Input:
+C     -----
+C                ptlon  : longitudes of target grid (real 2D)
+C                ptlat  : latitudes of target grid (real 2D)
+C                ptsurf : target grid square surfaces (real 2D)
+C                ktmsk  : mask of target grid (integer 2D)
+C                ktlon  : number of longitudes for target grid
+C                ktlat  : number of latitudes for target grid
+C                cdtper : target grid periodicity
+C                ktper  : number of overlapped points for target grid
+C                pinpt  : input field on source grid (real 2D)
+C                pslon  : longitudes of source grid (real 2D)
+C                pslat  : latitudes of source grid (real 2D)
+C                pssurf : source grid square surfaces (real 2D)
+C                ksmsk  : mask of source grid (integer 2D)
+C                kslon  : number of longitudes for source grid
+C                kslat  : number of latitudes for source grid
+C                cdsper : source grid periodicity
+C                ksper  : number of overlapped points for source grid
+C                kfield : current field number
+C                cdint  : type of interpolation to be performed
+C                cdtyp  : type of source grid
+C                cddim  : type of field (scalar or vector)
+C
+C     Output:
+C     ------
+C                poutp : output field on target grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     These are work arrays passed as arguments :
+C     plonz, platz, psgrb, psgra, psfrb, psfra 
+C
+C     Externals:
+C     ---------
+C     rgoptc, rgoptr, namset, nagset, cxgaig, igscint, namsst,
+C     nagsst, naflux.
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       1.1       L. Terray      94/08/01  modified: interpolation differ
+C                                          for scalar or vector in fscint
+C       2.0       L. Terray      95/12/15  modified: new structure
+C       2.2       L. Terray      97/11/28  added: grid type A,B,L in fscint
+C       2.3       L. Terray      99/03/01  corrected: calls to na(g-m)sst with
+C                                          inclusion of pointer ipdeb
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/08/11  modified: fscint extrapolation
+C                                          for periodic Z grids
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_anais
+      USE mod_parameter
+      USE mod_timestep
+      USE mod_unit
+      USE mod_printing
+CAC
+      USE mod_intbi
+      USE mod_intlin
+CAC
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) poutp(ktlon,ktlat), 
+     $    ptlon(ktlon,ktlat), ptlat(ktlon,ktlat)
+      REAL (kind=ip_realwp_p) pinpt(kslon,kslat), 
+     $    pslon(kslon,kslat), pslat(kslon,kslat)
+      REAL (kind=ip_realwp_p) pssurf(kslon,kslat), 
+     $    ptsurf(ktlon,ktlat)
+      REAL (kind=ip_realwp_p) plonz(ktlon), platz(ktlat), 
+     $    psgrb(kslon,kslat),
+     $     psgra(ktlon,ktlat), psfrb(kslon,kslat), psfra(ktlon,ktlat)
+      INTEGER (kind=ip_intwp_p) ktmsk(ktlon,ktlat), ksmsk(kslon,kslat)
+      CHARACTER*8 cdsper, cdtper
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*1 cdtyp, clref, cltyp
+      CHARACTER*6 cddim, cldim
+      CHARACTER*8 cdint, clord, clflg, clind
+      LOGICAL llinit, llsym
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE fiasco  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Interpolation package driving routine'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Assign local value to grid and field type variables to deal 
+C  with FSCINT set-up
+C
+      cltyp = cdtyp
+      cldim = cddim
+C
+C * Set up interpolation method
+C
+      IF (TRIM(cdint) == 'BICUBIPS' .OR. TRIM(cdint) == 'BILINIPS') THEN
+          IF ( cltyp == 'Z' .AND. TRIM(cdsper) == 'P' ) THEN
+              plonz = pslon ( :, kslat/2)
+              platz = pslat ( 1, :)
+              clflg='IPSL'
+          ELSE 
+              WRITE (UNIT = nulou,FMT = *) ' '
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'BICUBIPS and BILINIPS works ONLY',
+     $            ' with Z grid and P periodicity'
+              WRITE (UNIT = nulou,FMT = *) ' '
+              CALL HALTE ('STOP in fiasco')
+          ENDIF 
+          IF ( cldim == 'VECTOR' ) THEN 
+              IF (TRIM(cdint) == 'BICUBIPS') THEN
+                  WRITE(UNIT = nulou, FMT= *)
+     $                'Using intbi, vector mode'
+                  CALL intbi ( pinpt, plonz, platz, kslon, kslat
+     $                ,    poutp, ptlon, ptlat, ktlon*ktlat
+     $                ,    .TRUE.)
+              ENDIF 
+              IF (TRIM(cdint) == 'BILINIPS') THEN
+                  WRITE(UNIT = nulou, FMT= *)
+     $                'Using intlin, vector mode'
+                  CALL intlin ( pinpt, plonz, platz, kslon, kslat
+     $                ,    poutp, ptlon, ptlat, ktlon*ktlat
+     $                ,    .TRUE.)
+              ENDIF
+          ELSE 
+              IF (TRIM(cdint) == 'BICUBIPS') THEN
+                 WRITE(UNIT = nulou, FMT= *)
+     $                'Using intbi, scalar mode'
+                  CALL intbi ( pinpt, plonz, platz, kslon, kslat
+     $                ,    poutp, ptlon, ptlat, ktlon*ktlat
+     $                ,    .FALSE.)
+              ENDIF 
+              IF (TRIM(cdint) == 'BILINIPS') THEN
+                  WRITE(UNIT = nulou, FMT= *)
+     $                'Using intlin, scalar mode'
+                  CALL intlin ( pinpt, plonz, platz, kslon, kslat
+     $                ,    poutp, ptlon, ptlat, ktlon*ktlat
+     $                ,    .FALSE.)
+              ENDIF
+          ENDIF 
+          RETURN
+C
+        ELSE IF (TRIM(cdint) .EQ. 'BILINEAR') THEN
+          clflg = 'FSCINT'
+          CALL rgoptc('INTERP', 'LINEAIR', .TRUE.)
+        ELSEIF (TRIM(cdint) .EQ. 'BICUBIC') THEN
+          clflg = 'FSCINT'
+          CALL rgoptc('INTERP', 'CUBIQUE', .TRUE.)
+        ELSEIF (TRIM(cdint) .eq. 'NNEIBOR') THEN
+          clflg = 'FSCINT'
+          CALL rgoptc('INTERP', 'VOISIN', .TRUE.)
+        ELSEIF (TRIM(cdint) .EQ. 'SURFMESH') THEN
+          clflg = 'ANAISM'
+          llinit = linit(kfield)
+        ELSEIF (TRIM(cdint) .EQ. 'GAUSSIAN') THEN
+          clflg = 'ANAISG'
+          llinit = linit(kfield)
+        ELSE
+          WRITE (UNIT = nulou,FMT = *) '         ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>>> : unknown kind of interpolator'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' =======                   ============'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           '                     --->>>  CDINT = ',cdint
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' We STOP!!! check variable syntax '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL HALTE ('STOP in fiasco')
+      ENDIF
+      IF (clflg .eq. 'FSCINT') THEN
+          CALL rgoptc('INTERP', clord, .FALSE.)
+        ELSEIF (clflg .EQ. 'ANAISM') THEN
+          clord = 'SURFMESH'
+        ELSEIF (clflg .EQ. 'ANAISG') THEN
+          clord = 'GAUSSIAN'
+        ELSE
+          clord ='UNKNOWN'
+      ENDIF
+      IF (nlogprt .GE. 2) THEN
+          CALL prcout
+     $    ('Current interpolator is clord = ', clord, 1)
+      ENDIF
+C
+C* set up value to be given in case of extrapolation in fscint
+C
+      IF (clflg .eq. 'FSCINT') THEN
+          IF (cltyp .EQ. 'Z') THEN
+C
+C* No extrapolation for Z grids (global grid)
+C
+              CALL rgoptc ('EXTRAP', 'OUI', .TRUE.)
+          ELSE 
+              CALL rgoptc ('EXTRAP', 'VOISIN', .TRUE.)
+          ENDIF 
+          CALL rgoptc ('EXTRAP', clind , .false.)
+          IF (nlogprt .GE. 2) THEN
+              CALL prcout
+     $        ('Current extrapolation in FSCINT is clind =', clind, 1)
+          ENDIF
+      ENDIF
+C
+C* set up grid descriptors for fscint interpolator
+C
+      IF (clflg .eq. 'FSCINT') THEN
+          IF (cltyp .EQ. 'Z' .OR. cltyp .EQ. 'Y') THEN
+C
+C* here ig* descriptors are arbitrary (date of louis XVI's death)
+C
+              ig1 = 21
+              ig2 = 0
+              ig3 = 1
+              ig4 = 1793
+              zdllg = 1.0
+              zdllt = 1.0
+              zlgin = 0.0
+              zltin = 0.0
+              clref = 'L'
+              CALL cxgaig (clref, ig1z, ig2z, ig3z, ig4z,
+     $                     zltin, zlgin, zdllt, zdllg)
+              DO 110 ji = 1, kslon
+                plonz(ji) = pslon(ji,1) + 1.0
+ 110          CONTINUE
+              DO 120 jj = 1, kslat
+                platz(jj) = pslat(1,jj) + 1.0
+ 120          CONTINUE
+            ELSE IF (cltyp .EQ. 'G'.or. cltyp .EQ. 'A'
+     $            .OR. cltyp .EQ. 'B') THEN
+              ig1 = 0
+              ig2 = 0
+              ig3 = 0
+              ig4 = 0
+              llsym = .TRUE.
+            ELSE IF (cltyp .EQ. 'L') THEN 
+              zdllt = pslat(1,2) - pslat(1,1)
+              zdllg = pslon(2,1) - pslon(1,1)
+              zlgin = pslon(1,1)
+              zltin = pslat(1,1)
+              CALL cxgaig (cltyp, ig1, ig2, ig3, ig4,
+     $            zltin, zlgin, zdllt, zdllg)
+              llsym = .TRUE. 
+            ELSE
+              WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+              WRITE (UNIT = nulou,FMT = *) 
+     $               ' ===>>> : grid type not implemented yet'
+              WRITE (UNIT = nulou,FMT = *) 
+     $               ' ======   ====          ===========    '
+              WRITE (UNIT = nulou,FMT = *) 
+     $            '                --->>>  cltyp = ',
+     $                        cltyp
+              WRITE (UNIT = nulou,FMT = *) ' '
+              WRITE (UNIT = nulou,FMT = *) 
+     $             ' We STOP    !!! Check source grid type'
+              WRITE (UNIT = nulou,FMT = *) ' '
+              CALL HALTE ('STOP in fiasco')
+          ENDIF
+        ELSEIF (clflg .eq. 'ANAISM') THEN
+          IF (llinit) THEN
+C
+C* Mask values for both models
+C
+              ismsq = 1
+              itmsq = 1
+C
+C* If no intersection, give value imesh to nmesh array element
+C
+              imesh = 0
+              iwlun = nulcc
+C
+C* Get pointers for ANAISM interpolator parameters
+C
+              ipdeb = (naismfl(kfield)-1)*ig_maxwoa*ig_maxgrd+1
+              isdeb = (naismfl(kfield)-1)*ig_maxgrd+1
+C
+C* Set up surfmesh interpolation
+C
+              CALL namset (pslon, pslat, ksmsk, ismsq, kslon, kslat,
+     $                     cdsper, ksper,
+     $                     ptlon, ptlat, ktmsk, itmsq, ktlon, ktlat,
+     $                     cdtper, ktper, 
+     $                     cltyp,
+C
+C* Specific ANAISM parameters
+C
+     $                     amint(ipdeb), 
+     $                     nmint(ipdeb),
+     $                     naismvoi(kfield), psgrb, psgra,
+     $                     niwtm(kfield), iwlun, imesh,
+     $                     nmesh(isdeb), 
+     $                     naismfl(kfield))
+C
+C* Switch initialization flag
+C
+              linit(kfield) = .FALSE. 
+          ENDIF
+        ELSEIF (clflg .eq. 'ANAISG') THEN
+          IF (llinit) THEN
+              ismsq = 1
+              itmsq = 1
+              iwlun = nulgg
+C
+C* Get pointers for Anaisg interpolator parameters
+C
+              ipdeb = (naisgfl(kfield)-1)*ig_maxnoa*ig_maxgrd+1
+              CALL nagset (pslon, pslat, pssurf, 
+     $                     ksmsk, ismsq, kslon, kslat,
+     $                     ptlon, ptlat, ptsurf, 
+     $                     ktmsk, itmsq, ktlon, ktlat,
+     $                     cltyp,
+C
+C* Specific Anaisg parameters
+C
+     $                     agint(ipdeb),
+     $                     ngint(ipdeb),
+     $                     naisgvoi(kfield), psfrb, psfra,
+     $                     varmul(kfield), niwtg(kfield), iwlun, 
+     $                     naisgfl(kfield))
+C
+C* Switch off initialization flag
+C
+              linit(kfield) = .FALSE.  
+          ENDIF
+        ELSE
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>> : unknown interpolation package'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' ======   =======               ======='
+          WRITE (UNIT = nulou,FMT = *) 
+     $        '                    --->>>  clflg = ',
+     $                        clflg
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP        !!! Check interpolation package'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL HALTE ('STOP in fiasco')
+      ENDIF
+C
+C
+C*    2. Interpolation
+C        -------------
+C
+      IF (clflg .eq. 'FSCINT') THEN
+          IF (cltyp .eq. 'Z' .OR. cltyp .EQ. 'Y') THEN
+              CALL igscint (poutp, ktlon, ktlat, ptlat, ptlon,
+     $                      pinpt, kslon, kslat, cltyp, clref,
+     $                      ig1z, ig2z, ig3z, ig4z, .true.,
+     $                      plonz, platz, cldim)
+          ELSEIF (cltyp .eq. 'G'.or. cltyp .eq. 'A'
+     $            .OR. cltyp .eq. 'B'.or. cltyp .eq. 'L') THEN
+              CALL rgscint (poutp, ktlon, ktlat, ptlat, ptlon,
+     $                      pinpt, kslon, kslat, cltyp,
+     $                      ig1, ig2, ig3, ig4, llsym, cldim)
+          ELSE 
+              WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+              WRITE (UNIT = nulou,FMT = *) 
+     $               ' ===>>> grid type not implemented yet'
+              WRITE (UNIT = nulou,FMT = *) 
+     $               ' ====== ====          ===========    '
+              WRITE (UNIT = nulou,FMT = *) 
+     $            '                --->>>  cltyp = ',
+     $                        cltyp
+              WRITE (UNIT = nulou,FMT = *) ' '
+              WRITE (UNIT = nulou,FMT = *) 
+     $             ' WE STOP    !!! check source grid type'
+              WRITE (UNIT = nulou,FMT = *) ' '
+              CALL HALTE ('STOP in fiasco')         
+          ENDIF
+        ELSEIF (clflg .eq. 'ANAISM') THEN
+          itmsq = 1
+          ipdeb = (naismfl(kfield)-1)*ig_maxwoa*ig_maxgrd+1
+          CALL namsst (poutp, ktmsk, itmsq, ktlon, ktlat,
+     $                 amint(ipdeb), nmint(ipdeb), naismvoi(kfield),
+     $                 pinpt, kslon, kslat)
+        ELSEIF (clflg .eq. 'ANAISG') THEN
+          itmsq = 1
+          ipdeb = (naisgfl(kfield)-1)*ig_maxnoa*ig_maxgrd+1
+          CALL nagsst (poutp, ktmsk, itmsq, ktlon, ktlat,
+     $                 agint(ipdeb), ngint(ipdeb), naisgvoi(kfield),
+     $                 pinpt, kslon, kslat)
+        ELSE
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>> : unknown interpolation package'
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' ======   =======               ======='
+          WRITE (UNIT = nulou,FMT = *) 
+     $           '                      --->>>  clflg = ',
+     $                        clflg
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP        !!! Check interpolation package'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL HALTE ('STOP in fiasco')  
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine fiasco ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/filling.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/filling.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/filling.f	(revision 1677)
@@ -0,0 +1,546 @@
+      SUBROUTINE filling (pfild, pworka, pworkb, pworkc,
+     $                    plon, plat, klon, klat, kmask, kmesh,
+     $                    kunit, cdfic, cdmet)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *filling* - Fill up (and smooth or not) regional field with climatology 
+C
+C
+C     Purpose:
+C     -------
+C     Performs smooth or abrupt blending of a regional data set with a  
+C     global one for a Sea Surface Temperature or Sea Ice Extent field.
+C     The frequency of the global set can be interannual monthly, 
+C     climatological monthly or yearly. Sea-ice transitions are treated
+C     specifically: the ice is supposed to form or disappear on the first 
+C     day of the month.
+C
+C     N.B : The SST climatology must be in celsius. If not
+C           one has to change the value of local variable zmerg
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *filling(pfild, pworka, pworkb, pworkc, klon, klat, 
+C                        kmask, kmesh, kunit, cdfic, cdmet)*
+C
+C     Input:
+C     -----
+C                pfild  : field to be completed (real 2D) 
+C                plon   : grid longitude array (real 2D)
+C                plat   : grid latitude array (real 2D)
+C                klon   : number of longitude (integer)
+C                klat   : number of latitude (integer)
+C                kmask  : mask array (integer 2D)
+C                kmesh  : overlapped neighbors array (integer 2D)
+C                kunit  : climatological data filename logical unit (integer)
+C                cdfic  : climatological data filename  (character)
+C                cdmet  : filling method (character)
+C
+C     Output:
+C     ------
+C                pfild  : field completed (real 2D) 
+C
+C     Workspace:
+C     ---------
+C     These are work arrays passed as arguments:
+C     pworka, pworkb, pworkc
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       1.1       L. Terray      94/10/01  modified: lecture of climagrd
+C       2.0beta   L. Terray      95/12/10  modified: new structure
+C       2.0       L. Terray      96/02/01  modified: change on rewind()
+C       2.1       L. Terray      96/09/09  modified: flux correction term
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ----------------Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_analysis
+      USE mod_coast
+      USE mod_calendar
+      USE mod_unit
+      USE mod_smooth
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations----------------------
+C
+      REAL (kind=ip_realwp_p) pfild(klon, klat), plon(klon, klat), 
+     $    plat(klon, klat)
+      REAL (kind=ip_realwp_p) pworka(klon, klat),  pworkb(klon, klat) 
+      REAL (kind=ip_realwp_p) pworkc(klon, klat)
+      INTEGER (kind=ip_intwp_p) kmask(klon,klat), kmesh(klon, klat)
+      CHARACTER*8 cdmet, cdfic
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*3 clsmooth, clfield
+      CHARACTER*2 clclim
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN 
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE filling  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $     ' Filling and smoothing of field with climatology'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* initialize error flag for error routine
+C
+      iflag = 0
+C
+C* Get smoothing and time info
+C
+      clsmooth = cdmet(1:3)
+      clfield = cdmet(4:6)
+      clclim = cdmet(7:8)
+C
+C* Get congelation temperature for SST and SIE treatment.
+C
+      zmerg = -1.93
+C
+C
+C*    2. Getting climatological or interannual field
+C        -------------------------------------------
+C
+C* Monthly climatology
+C
+      IF (nlogprt .GE. 2) THEN
+          CALL prcout
+     $    ('Complementary data file is file =', cdfic, 1)
+      ENDIF
+      IF (clclim .EQ. 'SE' .OR. clclim .EQ. 'MO') THEN 
+          IF (nlogprt .GE. 2) THEN
+              WRITE (UNIT = nulou,FMT = *) ' '
+          ENDIF
+C
+C* Monthly climatology
+C
+          IF (clclim .EQ. 'SE') THEN 
+              IF (nlogprt .GE. 2) THEN
+                  CALL prtout
+     $            ('Monthly records skipped in climatology file 
+     $            nsrec =', nsrec, 1)
+              ENDIF
+C
+C* Read the right records
+C
+              REWIND kunit 
+              IF (nsrec .eq. 1) THEN
+                  READ (kunit) pworka
+                  READ (kunit) pworkb
+                ELSEIF (nsrec .gt. 1 .and. nsrec .lt. 12) THEN
+                  DO 210 ji = 1, nsrec - 1
+                    READ (kunit) pworka
+ 210              CONTINUE
+                  READ (kunit) pworka
+                  READ (kunit) pworkb
+                ELSEIF (nsrec .eq. 12 .or. nsrec .eq. 0) THEN
+                  DO 220 ji = 1, 11
+                    READ (kunit) pworka
+ 220              CONTINUE
+                  READ (kunit) pworka
+                  REWIND kunit 
+                  READ (kunit) pworkb
+                ELSE
+                  WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                ' ===>>> : wrong value for nsrec '
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                ' ======                   ===== '
+                  WRITE (UNIT = nulou,FMT = *) ' '
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                ' Variable nsrec = ',nsrec
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                ' We STOP !!! Check value for variable nsrec '
+                  CALL HALTE ('STOP in filling')
+              ENDIF
+C
+C* Monthly interannual data
+C
+            ELSE IF(clclim .EQ. 'MO') THEN 
+                IF (nlogprt .GE. 2) THEN
+                    CALL prtout
+     $                  ('Monthly records skipped in interannual file 
+     $                  nmrec =', nmrec, 1)
+                ENDIF
+C
+C* Read the right records
+C
+              REWIND kunit
+              IF (nmrec .eq. 0) THEN
+                  READ (kunit) pworka
+                  READ (kunit) pworkb
+                ELSEIF (nmrec .ge. 1) THEN
+                  DO 230 ji = 1, nmrec
+                    READ (kunit) pworka
+ 230              CONTINUE
+                  READ (kunit) pworka
+                  READ (kunit) pworkb
+              ENDIF
+          ENDIF  
+C
+C* Get all coefficients for time linear interpolation
+C
+          zpoid1 = FLOAT(njtwo - njnow) / FLOAT(njtwo - njone)
+          zpoid2 = 1.0 - zpoid1
+          zpoib1 = FLOAT(ndtwo - njnow) / FLOAT(ndtwo - ndone)
+          zpoib2 = 1.0 - zpoib1
+C
+C* Get climatological field for current day
+C
+C* Specific treatment for SST and SIE due to freezing temperature
+C  In both cases, one reads the temperature file and looks at 
+C  sea-ice transitions. One makes the assumption that the ice is
+C  formed or disappears on the first of the month.
+C
+          DO 240 jj = 1, klat
+            DO 250 ji = 1, klon
+C
+C* General case
+C
+              pworkc(ji,jj) = zpoid1 * pworka(ji,jj) +
+     $                        zpoid2 * pworkb(ji,jj)
+C
+C* If field is SST
+C
+              IF (clfield .EQ. 'SST') THEN
+C
+C* Sea Ice to Sea
+C
+                  IF (pworka(ji,jj) .LE. zmerg .AND. 
+     $                pworkb(ji,jj) .GT. zmerg) THEN
+                      IF (njnow .GT. 15) THEN
+                          CONTINUE
+                      ELSE
+                          pworkc(ji,jj) = zmerg * zpoib1 +
+     $                                    pworkb(ji,jj) * zpoib2
+                      ENDIF 
+                  ENDIF
+C
+C* Sea to Sea Ice
+C
+                  IF (pworka(ji,jj) .GT. zmerg .AND. 
+     $                pworkb(ji,jj) .LE. zmerg) THEN
+                      IF (njnow .GT. 15) THEN
+                          pworkc(ji,jj) = pworka(ji,jj) * zpoib1 +
+     $                                    zmerg * zpoib2
+                      ENDIF
+                  ENDIF
+C
+C* Sea to Sea
+C
+                  IF (pworka(ji,jj) .GT. zmerg .AND. 
+     $                pworkb(ji,jj) .GT. zmerg) THEN
+                      pworkc(ji,jj) = zpoid1 * pworka(ji,jj) +
+     $                                zpoid2 * pworkb(ji,jj)
+                  ENDIF
+              ENDIF
+C
+C* If field is SIE
+C 
+              IF (clfield .EQ. 'SIE') THEN             
+C
+C* Sea Ice to Sea Ice
+C
+                  IF (pworka(ji,jj) .LE. zmerg .AND. 
+     $                pworkb(ji,jj) .LE. zmerg) THEN
+                      pworkc(ji,jj) = 1.0
+                  ENDIF
+C
+C* Sea Ice to Sea
+C
+                  IF (pworka(ji,jj) .LE. zmerg .AND. 
+     $                pworkb(ji,jj) .GT. zmerg) THEN
+                      IF (njnow .gt. 15) THEN
+                          pworkc(ji,jj) = 1.0
+                        ELSE
+                          pworkc(ji,jj) = 0.0
+                      ENDIF
+                  ENDIF
+C
+C* Sea to Sea Ice
+C
+                  IF (pworka(ji,jj) .GT. zmerg .AND. 
+     $                pworkb(ji,jj) .LE. zmerg) THEN
+                      IF (njnow .gt. 15) THEN
+                          pworkc(ji,jj) = 0.0
+                      ELSEIF (njnow .eq. 1) THEN
+                          pworkc(ji,jj) = 2.0
+                      ELSE
+                          pworkc(ji,jj) = 1.0
+                      ENDIF
+                  ENDIF
+C
+C* Sea to Sea
+C
+                  IF (pworka(ji,jj) .GT. zmerg .AND. 
+     $                pworkb(ji,jj) .GT. zmerg) THEN
+                      pworkc(ji,jj) = 0.0
+                  ENDIF
+              ENDIF 
+ 250        CONTINUE
+ 240      CONTINUE
+C
+C* Annual climatology
+C
+      ELSE IF (clclim .EQ. 'AN') THEN
+          READ (kunit) pworkc
+      ELSE 
+          CALL prcout ('This type of climatology cannot be used  -
+     $                 clim = ', clclim, 1)
+      ENDIF
+C
+C* Blending and smoothing
+C
+C* Storing of climatology field interpolated in intermediate array pworka
+C
+      DO 260 jj = 1, klat
+        DO 270 ji = 1, klon
+          pworka(ji,jj) = pworkc(ji,jj)
+ 270    CONTINUE
+ 260  CONTINUE
+C* SST case
+      IF (clfield .EQ. 'SST') THEN
+C
+C* Put interpolated values in intermediate array if:
+C     - the point is an atmosphere sea point
+C     - there is at least one underlying ocean sea point
+C
+          DO 280 jj = 1, klat
+            DO 290 ji = 1, klon
+              IF (kmesh(ji,jj) .NE. 0 .AND. kmask(ji,jj) .EQ. 0) THEN
+                  pworka(ji,jj) = pfild(ji,jj)
+              ENDIF
+ 290        CONTINUE
+ 280      CONTINUE
+C
+C* If needed, do coast mismatch correction
+C  --> Special treatment for coastal points where there is a
+C  --> a mismatch between ocean and atmosphere land sea masks
+C  --> The array npcoast is calculated in routine coasts.f
+C  --> icoor and jcoor are externally defined functions
+C
+          IF(nfcoast .EQ. 1) THEN
+C* If first iteration, initialize coast mismatch data
+              IF (lcoast) THEN
+                  itmsq = 1
+                  CALL coasts (plon, plat, kmask, itmsq,
+     $                         klon, klat, kmesh)
+C* Switch off flag
+                  lcoast = .FALSE.
+              ENDIF
+              IF (nlogprt .GE. 2) THEN
+                  WRITE (UNIT = nulan,FMT = *) ' '
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '               * Model run date * '
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '               * -------------- * '
+                  WRITE (UNIT = nulan,FMT = *) ' '
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '        Year  --->>> ',nanow
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '       Month  --->>> ',nmnow
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '         Day  --->>> ',njnow
+                  WRITE (UNIT = nulan,FMT = *) ' '
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '      Correct for coast mismatch '
+                  WRITE (UNIT = nulan,FMT = *) 
+     $            '      ************************** '
+                  WRITE (UNIT = nulan,FMT = *) ' '
+              ENDIF
+              DO 291 jc = 1, ncoast
+                iic = icoor(npcoast(jc,1), klon)
+                ijc = jcoor(npcoast(jc,1), klon)
+                ztmptot = 0.
+                DO 292 jn = 3, 2 + npcoast(jc,2)
+                  iiic = icoor(npcoast(jc,jn), klon)
+                  ijjc = jcoor(npcoast(jc,jn), klon)
+                  ztmptot = ztmptot + pfild(iiic,ijjc)
+ 292            CONTINUE
+C
+C* Print old and new values
+C
+                IF (nlogprt .GE. 2) THEN
+                    WRITE (UNIT = nulan,FMT = *) 
+     $              ' Resetting SST at point (i,j)= ',iic,ijc
+                    WRITE (UNIT = nulan,FMT = *) 
+     $              ' Old SST value : SST = ', pfild(iic,ijc)
+                    WRITE (UNIT = nulan,FMT = *) 
+     $              ' Clim SST value : SST = ', pworka(iic,ijc)
+                ENDIF
+C
+C* Get new value
+C
+                pfild(iic,ijc) = ztmptot / float(npcoast(jc,2))
+                IF (nlogprt .GE. 2) THEN
+                    WRITE (UNIT = nulan,FMT = *) 
+     $              ' New SST value : SST = ', pfild(iic,ijc)
+                ENDIF
+C
+C* Copy new value into intermediate array
+C
+                pworka(iic,ijc) = pfild(iic,ijc)
+ 291          CONTINUE  
+          ENDIF              
+C
+C* SIE case : we assign the new field to climatology i.e we do nothing
+C
+      ELSE IF (clfield .EQ. 'SIE') THEN
+          CONTINUE 
+C
+C* General case: put interpolated value if there is an
+C                underlying grid point (whether land or sea)
+C
+      ELSE  
+          DO 293 jj = 1, klat
+            DO 294 ji = 1, klon
+              IF (kmesh(ji,jj) .NE.  0) THEN
+                  pworka(ji,jj) = pfild(ji,jj)
+              ENDIF 
+ 294        CONTINUE
+ 293      CONTINUE
+      ENDIF
+C
+C
+C*    3. Do the smoothing on  borders (only for SST)
+C        ----------------------------
+C
+      IF (clfield .EQ. 'SST' .AND. clsmooth .EQ. 'SMO') THEN 
+C
+C* First South and North borders
+C
+          DO 310 jk = nsltb, nslte
+            DO 320 ji = 1, klon
+              IF (kmesh(ji,jk) .NE. 0 .AND. kmask(ji,jk) .EQ. 0) THEN
+                  pworka(ji,jk) = qalfa * (jk - nsltb) * pfild(ji,jk)
+     $                + (1.-qalfa * (jk - nsltb)) * pworkc(ji,jk)
+              ENDIF
+ 320        CONTINUE
+ 310      CONTINUE
+          DO 330 jk = nnltb, nnlte, -1
+            DO 340 ji = 1, klon
+              IF (kmesh(ji,jk) .NE. 0 .AND. kmask(ji,jk) .EQ. 0) THEN
+                  pworka(ji,jk) = qalfa * (nnltb - jk) * pfild(ji,jk)
+     $                +  (1.-qalfa * (nnltb - jk)) * pworkc(ji,jk)
+              ENDIF
+ 340        CONTINUE
+ 330      CONTINUE
+C
+C* Western border
+C
+          DO 350 jj = nslte + 1, nnlte - 1
+            DO 360 ji = 1, nwlgmx
+              IF (kmesh(ji,jj) .EQ. 0 .AND. 
+     $            kmesh(ji + 1,jj) .NE. 0) THEN
+                  DO 370 jk = 1, nliss
+                    pworka(ji + jk - 1,jj) = qbeta*(jk - 1) *
+     $                                       pfild(ji + jk - 1,jj) +
+     $                                       pworkc(ji + jk - 1,jj) *
+     $                                       (1.-qbeta*(jk - 1))
+ 370              CONTINUE
+              ENDIF
+ 360        CONTINUE
+ 350      CONTINUE
+C
+C* Eastern border
+C
+          DO 380 jj = nslte + 1, nnlte - 1
+            DO 390 ji = klon, nelgmx, -1
+              IF (kmesh(ji,jj) .EQ. 0 .AND. 
+     $            kmesh(ji - 1,jj) .NE. 0) THEN
+                  DO 391 jk = 1, nliss
+                    pworka(ji - jk + 1,jj) = qbeta*(jk - 1) *
+     $                                       pfild(ji - jk + 1,jj) +
+     $                                       pworkc(ji - jk + 1,jj) *
+     $                                       (1.-qbeta*(jk - 1))
+ 391              CONTINUE 
+              ENDIF
+ 390        CONTINUE
+ 380      CONTINUE 
+C
+C* Calculate and write flux correction term cfldcor on unit nlucor
+C
+          CALL prcout('Calculate flux correction term', cfldcor, 1)
+          CALL szero(pworkb,klon*klat)
+          DO 392 jj = 1, klat
+            DO 393 ji = 1, klon
+C
+C* The correction term is estimated only for atmosphere sea points with 
+C  underlying ocean sea points
+C
+              IF (kmesh(ji,jj) .NE. 0 .AND. kmask(ji,jj) .EQ. 0) THEN
+                  pworkb(ji,jj) = pfild(ji,jj) - pworka(ji,jj)
+              ENDIF 
+ 393        CONTINUE
+ 392      CONTINUE
+C
+C* Rewind unit nlucor and write
+C
+          IF (nlogprt .GE. 2) THEN
+              CALL prtout('Write it on logical unit ', nlucor, 2)
+          ENDIF
+          REWIND nlucor
+          CALL locwrite(cfldcor, pworkb, klon*klat, nlucor, iflag)
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in writing field',
+     $            cfldcor, 1)
+              CALL prtout
+     $            ('Error in writing logical unit', nlucor, 2)
+              CALL HALTE('STOP in filling')
+          ENDIF 
+      ENDIF 
+C
+C* Assign intermediate array pworka values to final array pfild
+C
+      DO 394 jj = 1, klat
+        DO 395 ji = 1, klon
+          pfild(ji,jj) = pworka(ji,jj)
+ 395    CONTINUE
+ 394  CONTINUE
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine filling ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/fpecatch.c
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/fpecatch.c	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/fpecatch.c	(revision 1677)
@@ -0,0 +1,6 @@
+#if defined use_comm_SIPC || defined use_comm_GMEM
+#include <signal.h>
+extern void getfpe_();
+void fpecatch_()
+{   signal(SIGFPE,getfpe_); }
+#endif
Index: CPL/oasis3/trunk/src/mod/oasis3/src/getfld.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/getfld.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/getfld.F	(revision 1677)
@@ -0,0 +1,715 @@
+      SUBROUTINE getfld (kindex, kfield, kiter)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *getfld* - reading routine
+C
+C
+C     Purpose:
+C     -------
+C     Read coupling fields for iteration kiter
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *getfld (kindex, kfield, kiter)*
+C
+C     Input:
+C     -----
+C                kindex : current active fields index array
+C                kfield : current active fields total number
+C                kiter  : iteration number
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     PIPE_Recv, CLIM_Import, SVIPC_read
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.1       L. Terray      96/08/05  modified: correct printing of
+C                                          diagnostic (variable clname)
+C       2.2       S. Valcke      97/08/22  added: introduction of SVIPC
+C       2.2       L.Terray       97/09/20  added: extra test in delay mode
+C                                          + general cleaning + test on
+C                                          info mode
+C       2.3       L. Terray      99/03/01  modified: reading in delay mode
+C                                          (negative values mean one must
+C                                           read files, 0 means channel)
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* -----------------Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_clim
+#endif
+      USE mod_parameter
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_sipc
+      USE mod_unitncdf
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_unit
+      USE mod_hardware
+      USE mod_label
+      USE mod_printing
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: info, 
+     $    iflag
+      CHARACTER*8 clname, clfic
+      CHARACTER*53 clabel
+      INTEGER (kind=ip_intwp_p) itime(3)
+      CHARACTER*3 cljobnam
+      INTEGER (kind=ip_intwp_p) il_varid, il_dimid, il_dimlen
+      INTEGER (kind=ip_intwp_p) il_nvar, il_natt, il_att
+      INTEGER (kind=ip_intwp_p) ist(3), icnt(3)
+      INTEGER (kind=ip_intwp_p) il_indice_since, il_cf_units
+      LOGICAL l_unit_found
+      CHARACTER(len=60) cl_attname
+      CHARACTER(len=17) cl_units, cl_units_cf
+      CHARACTER(len=260) cl_atttext
+      INTEGER (kind=ip_intwp_p) , parameter :: ip_nb_cf_units = 63
+      CHARACTER(len=17), dimension(ip_nb_cf_units) :: 
+     $         cl_cf_time_units = 
+     $         (/'second           ', 'minute           ',
+     $           'hour             ', 'day              ',
+     $           's                ', 'sec              ',
+     $           'shake            ', 'sidereal_day     ',
+     $           'sidereal_hour    ', 'sidereal_minute  ',
+     $           'sidereal_second  ', 'sidereal_year    ',
+     $           'tropical_year    ', 'lunar_month      ',
+     $           'common_year      ', 'leap_year        ',
+     $           'Julian_year      ', 'Gregorian_year   ',
+     $           'sidereal_month   ', 'tropical_month   ',
+     $           'd                ', 'min              ',
+     $           'hr               ', 'h                ',
+     $           'fortnight        ', 'week             ',
+     $           'jiffy            ', 'jiffies          ',
+     $           'year             ', 'yr               ',
+     $           'a                ', 'eon              ',
+     $           'month            ',
+     $           'seconds          ', 'minutes          ',
+     $           'hours            ', 'days             ',
+     $           'secs             ',
+     $           'shakes           ', 'sidereal_days    ',
+     $           'sidereal_hours   ', 'sidereal_minutes ',
+     $           'sidereal_seconds ', 'sidereal_years   ',
+     $           'tropical_years   ', 'lunar_months     ',
+     $           'common_years     ', 'leap_years       ',
+     $           'Julian_years     ', 'Gregorian_years  ',
+     $           'sidereal_months  ', 'tropical_months  ',
+     $           'ds               ', 'mins             ',
+     $           'hrs              ', 'hs               ',
+     $           'fortnights       ', 'weeks            ',
+     $           'years            ', 'yrs              ',
+     $           'as               ', 'eons             ',
+     $           'months           '/)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Allocation and initialization
+C        -----------------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE getfld  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Get coupling fields'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      imrca = 0
+      imrcb = 0
+      itime(:)=0
+      ist(:)=0
+      icnt(:)=0
+      ALLOCATE(iflag(ig_nfield))
+      ALLOCATE(info(ig_nfield))
+      CALL izero (iflag, ig_nfield)
+      CALL izero (info, ig_nfield)
+C
+C*    2. Loop on active fields for iteration kiter
+C        -----------------------------------------
+!$omp parallel do default (shared)
+!$omp+ private(jf,iloc,iadrold,isizold,ilabel)
+!$omp+ private(clabel,clname,clfic,iunit)
+!$omp+ private(iseqn,il_varid,n_reaty)
+
+C
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+         iloc = kindex(jf)
+         iadrold = nadrold(iloc)
+         isizold = nsizold(iloc)
+         ilabel = numlab(iloc)
+         clabel = cfldlab(ilabel)
+         clname = cnaminp(iloc)
+         clfic = cficinp(iloc)
+         iunit = nluinp(iloc)
+         iseqn = nseqn(iloc)
+         ilagn = nlagn(iloc)
+C
+C* Print field name
+C
+         IF (nlogprt .GE. 1) THEN
+            CALL prcout('Reading of field : ', clname, 2)
+         ENDIF
+         IF (nlogprt .GE. 2) THEN
+            CALL prcout('Field long name : ', clabel, 2)
+         ENDIF
+C
+C* - Get coupling fields
+C
+C* Specific treatment for first iteration 
+C
+#if defined use_comm_NONE || defined use_comm_SIPC
+         ilagn = 1
+#endif
+         IF (kiter .EQ. 0 .AND. ilagn .GT. 0) THEN
+C
+C* Reconnect data file to appropriate unit
+C
+            IF (lncdfrst) THEN
+               ist(1)=1 
+               ist(2)=1
+               ist(3)=kiter+1
+               icnt(1)=nlonbf(iloc) 
+               icnt(2)=nlatbf(iloc)
+               icnt(3)=1
+C     
+               CALL hdlerr
+     $          (NF_INQ_VARID(nc_inpid(iloc),clname,il_varid),'getfld')
+#if defined use_comm_NONE
+               nc_invartimeid=0
+               istat = NF_INQ_VARID(nc_inpid(iloc),'time_counter',
+     $              nc_invartimeid ) 
+               IF (istat .ne. NF_NOERR) then
+                   istat = NF_INQ_VARID(nc_inpid(iloc),'time',
+     $                                  nc_invartimeid)
+               ENDIF
+               IF (istat .ne. NF_NOERR) then
+                   istat = NF_INQ_VARID(nc_inpid(iloc),'TIME_COUNTER',
+     $                                  nc_invartimeid)
+               ENDIF
+               IF (istat .ne. NF_NOERR) then
+                   istat = NF_INQ_VARID(nc_inpid(iloc),'TIME',
+     $                                  nc_invartimeid)
+               ENDIF
+               IF (istat .ne. NF_NOERR) then
+                   istat = NF_INQ_UNLIMDIM(nc_inpid(iloc),
+     $                     il_dimid)
+                   IF (istat .eq. NF_NOERR) then
+                     istat = NF_INQ_DIMNAME(nc_inpid(iloc),il_dimid,
+     $                       nc_invartime_name)
+                       IF (istat .eq. NF_NOERR) then
+                           istat = NF_INQ_VARID(nc_inpid(iloc),
+     $                             nc_invartime_name, nc_invartimeid)
+                       ENDIF
+                   ENDIF
+               ENDIF
+               l_unit_found=.FALSE.
+               IF (istat .ne. NF_NOERR) then
+                   CALL hdlerr(NF_INQ_NVARS(nc_inpid(iloc),il_nvar),
+     $                         'getfld')
+                  DO nc_invartimeid=1,il_nvar
+                    CALL hdlerr(NF_INQ_VARNATTS(nc_inpid(iloc),
+     $                             nc_invartimeid, il_natt),'getfld')
+                    DO il_att=1,il_natt
+                       CALL hdlerr(NF_INQ_ATTNAME(nc_inpid(iloc),
+     $                          nc_invartimeid, il_att, cl_attname),
+     $                          'getfld')
+                       IF ( cl_attname .eq. 'units' ) THEN
+                         CALL hdlerr(NF_GET_ATT_TEXT(
+     $                          nc_inpid(iloc),nc_invartimeid ,'units',
+     $                          cl_atttext),'getfld')
+                         il_indice_since=INDEX(cl_atttext,'since')
+                         IF ( il_indice_since .ne. 0 ) THEN
+                            cl_units=cl_atttext(1:il_indice_since-1)
+                            cl_units=ADJUSTL(cl_units)
+                            cl_units=TRIM(cl_units)
+                            DO il_cf_units =1, ip_nb_cf_units
+                               cl_units_cf=cl_cf_time_units(il_cf_units)
+                              IF ( cl_units .EQ. cl_units_cf )
+     $                           l_unit_found=.TRUE.
+                              CALL case_change(cl_units_cf,1)
+                              IF ( cl_units .EQ. cl_units_cf)
+     $                           l_unit_found=.TRUE.
+                            ENDDO
+                            IF ( l_unit_found )  THEN
+                              istat = NF_NOERR
+                              GO TO 230
+                            ENDIF
+                         ENDIF
+                       ENDIF
+                    ENDDO
+                  ENDDO
+ 230              CONTINUE
+               ENDIF
+C
+               IF (istat .ne. NF_NOERR) then
+                  WRITE(nulou,*) 'WARNING: Time variable not found'
+                  WRITE(nulou,*) ''
+                  IF ( nitfn .gt. 0) THEN
+                     WRITE(nulou,*) 'Check coherence between'
+                     WRITE(nulou,*) 'namcouple timestep number'
+                     WRITE(nulou,*) 'and input file dimension'
+                     WRITE (nulou, *)
+                     CALL HALTE('STOP in getfld')
+                  END IF
+             WRITE(nulou,*) 'Interpolation only for one time iteration'
+                  nc_invartime_name = 'time_counter'
+               ELSE
+                  CALL hdlerr
+     $              (NF_INQ_VARNAME(nc_inpid(iloc),nc_invartimeid,
+     $               nc_invartime_name),'getfld')
+C
+C                 Check coherence 
+C                 between namcouple timestep number
+C                 and input file dimension
+C    
+                  CALL hdlerr
+     $              (NF_INQ_VARDIMID(nc_inpid(iloc),nc_invartimeid,
+     $               il_dimid),'getfld')
+                  CALL hdlerr
+     $              (NF_INQ_DIMLEN(nc_inpid(iloc),il_dimid,
+     $               il_dimlen),'getfld')
+                  IF ( il_dimlen .le. nitfn ) then
+                      WRITE(nulou,*) 'Incoherence between'
+                      WRITE(nulou,*) 'namcouple timestep number'
+                      WRITE(nulou,*) 'and input file dimension'
+                      WRITE(nulou,*) ''
+                      CALL HALTE('STOP in getfld')
+                  ENDIF
+               ENDIF
+#else
+               nc_invartime_name = 'time_counter'
+#endif
+               CALL hdlerr
+     $              (NF_INQ_VARTYPE(nc_inpid(iloc),il_varid,n_reaty),
+     $              'getfld')
+               IF (n_reaty .eq. NF_FLOAT) THEN
+c                  IF (kind(rl_testvar). ne. 4) THEN
+                  IF ( ip_realwp_p .ne. ip_single_p ) THEN
+                     WRITE (nulou, *)
+     $         'Incoherence: Oasis is compiled in double precision'
+                     WRITE (nulou, *)
+     $      'but Restart auxiliary file contains single precision REAL'
+                     CALL HALTE('STOP in getfld')
+                  ENDIF
+                  CALL hdlerr(NF_GET_VARA_REAL(nc_inpid(iloc), 
+     $                 il_varid, ist, icnt, 
+     $                fldold(iadrold:iadrold+isizold-1)), 'getfld')
+C
+#if defined use_comm_NONE
+                  IF (nc_invartimeid .ne. 0) then
+                      istat = NF_GET_VARA_REAL(nc_inpid(iloc),
+     $                     nc_invartimeid, ist(3), icnt(3), rtime_val)
+                      IF (istat .eq. NF_NOERR) then
+                         istatus=NF_GET_VARA_REAL(nc_inpid(iloc),
+     $                    nc_invartimeid, ist(3), icnt(3), rtime_val)
+                      ENDIF
+                  ENDIF
+C
+#endif
+               ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+c                  IF (kind(rl_testvar). ne. 8) THEN
+                  IF ( ip_realwp_p .ne. ip_double_p ) THEN
+                     WRITE (nulou, *)
+     $          'Incoherence: Oasis is compiled in single precision'
+                     WRITE (nulou, *)
+     $    'but Restart auxiliary file contains double precision REAL'
+                     CALL HALTE('STOP in getfld')
+                  ENDIF               
+                  CALL hdlerr(NF_GET_VARA_DOUBLE(nc_inpid(iloc), 
+     $                 il_varid, ist, icnt, 
+     $                fldold(iadrold:iadrold+isizold-1) ), 'getfld')
+C
+#if defined use_comm_NONE
+                  IF (nc_invartimeid .ne. 0) then
+                      istat = NF_GET_VARA_DOUBLE(nc_inpid(iloc),
+     $                     nc_invartimeid, ist(3), icnt(3), rtime_val)
+                      IF (istat .eq. NF_NOERR) then
+                         istatus=NF_GET_VARA_DOUBLE(nc_inpid(iloc),
+     $                    nc_invartimeid, ist(3), icnt(3), rtime_val)
+                      ENDIF
+                  ENDIF
+C
+#endif
+               ENDIF
+            ELSE
+cSL
+C
+C* Reconnect data file to appropriate unit; this first close is necessary !
+C
+                    CLOSE(iunit)
+                    OPEN (UNIT=iunit,FILE=clfic,STATUS ='UNKNOWN',
+     $                      FORM ='UNFORMATTED',IOSTAT = iost)
+                    IF (iost .eq. 0) then
+                        IF (nlogprt .GE. 2) THEN
+                            WRITE(UNIT = nulou, FMT = 2100)iunit,clfic
+                        ENDIF
+                    ELSE
+                        CALL prtout
+     $                  ('No binary transfert file for field ',iloc,1)
+                        CALL HALTE('STOP in getfld') 
+                    ENDIF
+cSL
+               IF (lmodinf) THEN 
+                  CALL locreadh (clname, cljobnam, itime,  
+     $                 fldold(iadrold), isizold, iunit, iflag(iloc)) 
+               ELSE 
+                  CALL locread (clname, fldold(iadrold), isizold,
+     $                 iunit, iflag(iloc))
+               ENDIF
+               IF (iflag(iloc) .NE. 0) THEN
+                  CALL prcout ('WARNING: problem in reading field',
+     $                 clname, 1)
+                  CALL prtout ('Error reading logical unit', iunit, 2)
+                  CALL HALTE('STOP in getfld')
+               ENDIF
+C
+            ENDIF
+C
+C* Next iterations
+C
+         ELSE
+C
+C* PIPE and NONE case
+C
+#ifdef use_comm_PIPE
+C
+C* Wait for message
+C
+            CALL PIPE_Recv (clname, kiter)
+#endif
+#if defined use_comm_PIPE || defined use_comm_NONE
+C
+C* Reconnect data file to appropriate unit IF not already done
+C
+            IF (lncdfrst) THEN
+               CALL hdlerr(NF_OPEN(clfic,NF_NOWRITE,nc_inpid(iloc)),
+     $             'getfld')
+               ist(1)=1 
+               ist(2)=1
+               ist(3)=1+kiter
+               icnt(1)=nlonbf(iloc)
+               icnt(2)=nlatbf(iloc)
+               icnt(3)=1
+               istatus=NF_INQ_VARID(nc_inpid(iloc),clname,il_varid)
+               
+               istatus=NF_INQ_VARID(nc_inpid(iloc),nc_invartime_name,
+     $                        nc_invartimeid)
+               IF (n_reaty .eq. NF_FLOAT) THEN
+                  CALL hdlerr(NF_GET_VARA_REAL(nc_inpid(iloc), 
+     $                 il_varid,ist,icnt,
+     $                 fldold(iadrold:iadrold+isizold-1)),'getfld') 
+                  IF (nc_invartimeid .ne. 0) 
+     $            CALL hdlerr(NF_GET_VARA_REAL(nc_inpid(iloc),
+     $                 nc_invartimeid, ist(3), icnt(3), rtime_val)
+     $                 , 'getfld') 
+               ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                  CALL hdlerr(NF_GET_VARA_DOUBLE(nc_inpid(iloc), 
+     $                 il_varid,ist,icnt,
+     $                 fldold(iadrold:iadrold+isizold-1)),'getfld')
+                  IF (nc_invartimeid .ne. 0) 
+     $               CALL hdlerr(NF_GET_VARA_DOUBLE(nc_inpid(iloc),
+     $                 nc_invartimeid, ist(3), icnt(3), rtime_val)
+     $                 , 'getfld')
+               ENDIF
+               CALL hdlerr(NF_CLOSE(nc_inpid(iloc)), 'getfld')
+            ELSE
+               OPEN (UNIT=iunit,FILE=clfic,STATUS ='UNKNOWN',
+     $              FORM ='UNFORMATTED',IOSTAT = iost)
+               IF (iost .eq. 0) then
+                  IF (nlogprt .GE. 2) THEN
+                     WRITE(UNIT = nulou, FMT = 2100)iunit,clfic
+                  ENDIF
+               ELSE
+                  CALL prtout
+     $                 ('No binary transfert file for field ',iloc,1)
+                  CALL HALTE('STOP in getfld') 
+               ENDIF
+               IF (lmodinf) THEN 
+                  CALL locreadh (clname, cljobnam, itime,  
+     $                 fldold(iadrold),isizold,iunit,iflag(iloc)) 
+               ELSE
+                  CALL locread (clname, fldold(iadrold), 
+     $                 isizold, iunit, iflag(iloc))
+               ENDIF 
+               IF (iflag(iloc) .NE. 0) THEN 
+                  clname = cnaminp(iloc)
+                  CALL prcout('Problem reading field',clname,1)
+                  CALL prtout ('Error reading lunit', iunit, 2)
+                  CALL HALTE ('STOP in getfld')
+               ENDIF
+               CLOSE (UNIT = iunit, IOSTAT = ios)
+               IF (ios .EQ. 0) THEN
+                  IF (nlogprt .GE. 2) THEN
+                     WRITE(UNIT=nulou,FMT=2200) iunit, clfic
+                  ENDIF
+               ELSE
+                  CALL prtout('Problem in closing unit',iunit,2)
+                  CALL prtout('Error message nbrr is= ', ios, 2)
+                  CALL HALTE('STOP in getfld')
+               ENDIF 
+            ENDIF
+C
+C* SIPC or GMEM case
+C
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+C
+            ipbytecha=kind('A')
+            ipbyteint=kind(itime)
+            ipbyterea=kind(fldold)
+C
+C* Read encapsulated infos in field-specific shared memory pool
+C  (experiment name, initial date, time since start, iteration number)
+C
+            IF (lmodinf) THEN 
+               isizeinp = 3*ipbytecha
+               CALL SVIPC_read(mpoolidin(iloc), cljobnam 
+     $              , isizeinp, imrca)
+               isizeinp = 3*ipbyteint
+               CALL SVIPC_read(mpoolidin(iloc), itime 
+     $              , isizeinp, imrcb)
+C
+C* Find error if any
+C
+               IF (imrca .LT. 0 .OR. imrcb .LT. 0) THEN
+                  CALL prcout
+     $   ('Problem in reading encapsulated infos for field', clname, 1)
+                  CALL HALTE ('STOP in getfld')
+               ELSE
+                  CALL prcout
+     $   ('Read encapsulated infos in SHM pool for field', clname, 1)
+               ENDIF 
+            ENDIF
+C
+C* Read part of macro array in field-specific shared memory pool
+C
+            isizeinp = isizold * ipbyterea
+            WRITE(UNIT = nulou, FMT = *) 
+     $           'Reading field data from pool = ',mpoolidin(iloc) 
+            CALL SVIPC_read(mpoolidin(iloc),
+     $           fldold(iadrold), isizeinp, imrc)
+C
+C* Find error if any
+C
+            IF (imrc .LT. 0) THEN
+               CALL prcout
+     $           ('Problem in reading the field in SHM pool:',clname,1)
+               CALL HALTE ('STOP in getfld')
+            ELSE
+               CALL prcout
+     $            ('Read field in SHM pool:', clname, 1)
+            ENDIF
+C
+C* CLIM case
+C
+#elif defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE 
+!$omp critical
+            CALL CLIM_Import 
+     $           (ig_portin_id(iloc), kiter*nstep, fldold(iadrold), 
+     $           info(iloc))
+!$omp end critical
+            IF (info(iloc) .NE. CLIM_Ok) THEN 
+               CALL prcout('Problem in reading field on port',
+     $              clname, 1)
+               CALL prtout('error code number', info(iloc), 2)
+               CALL HALTE ('STOP in getfld')
+            ENDIF
+#else
+            CALL prcout 
+     $           ('Wrong channel option for field', clname, 1)
+#endif
+         IF (lmodinf .AND. nlogprt .GE. 2) THEN 
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' Encapsulated data for current field is :' 
+            CALL prcout ('Experiment name', cljobnam, 1)
+            CALL prtout ('Initial date', itime(1), 2)
+            CALL prtout ('Iteration number', itime(2), 2)
+            CALL prtout ('Time since start', itime(3), 2)
+         ENDIF 
+      ENDIF 
+ 210  CONTINUE
+C
+C* Close units or netcdf restart files if first iteration
+C
+      IF (kiter .EQ. 0) THEN
+          DO 220 jf = 1, kfield
+            iloc = kindex(jf)
+            ilagn = ig_lag(iloc)
+            IF (ilagn .GT. 0) THEN
+            isamefic=0
+            DO 225 jj = 1, jf-1
+              IF (nluinp(jf) .eq. nluinp(jj)) isamefic=isamefic+1
+ 225        END DO
+            IF (isamefic .lt. 1) THEN
+                IF (lncdfrst) THEN
+                    CALL hdlerr(NF_CLOSE(nc_inpid(jf)), 'getfld')
+                ELSE
+                    CLOSE (UNIT = nluinp(jf), IOSTAT = ios)
+                    IF (ios .NE. 0) THEN
+                        CALL prtout('Problem in closing unit',iunit,2)
+                        CALL prtout('Error message number is = ',ios,2)
+                        CALL HALTE('STOP in getfld')
+                    ELSE
+                        IF (nlogprt .GE. 2) THEN
+                            WRITE(UNIT=nulou, FMT=2200) iunit, clfic
+                        ENDIF
+                    ENDIF
+                ENDIF
+            ENDIF
+            ENDIF
+ 220      CONTINUE
+      ENDIF
+C
+C* Formats
+C
+ 2100 FORMAT(/,5X,' Unit ',I2,' has been connected to file ',A8)
+ 2200 FORMAT(/,5X,' Unit ',I2,' has been disconnected from file ',A8)
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN 
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine getfld ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      DEALLOCATE(iflag)
+      DEALLOCATE(info)
+      RETURN
+      END
+C
+C====================================================================
+C
+          subroutine case_change( string, type )
+C
+C Purpose
+C _______
+C
+C   This converts each lower case alphabetic letter in STRING to upper
+C   case, or vice versa.
+C
+C
+C Arguments
+C _________
+C
+C   string  (INPUT/OUTPUT) character(len=*)
+C           The string to convert
+C
+C   TYPE    (INPUT/OUTPUT) integer(i1b)
+C           Define the conversion. Specifically,
+C
+C               If TYPE = 1 = TOUPPER,    conversion is lower to upper
+C               If TYPE = 2 = TOLOWER,    conversion is upper to lower
+C               If TYPE = 3 = CAPITALIZE, use upper for first letter; lower for rest
+C
+C           Definitions of TOUPPER, TOLOWER and CAPITALIZE may be obtained from
+C           the host module Strings.
+C
+C
+C Further Details
+C _______________
+C
+C   All non-alphabetic characters are left unchanged.
+C   It uses the underlying machine collating sequence.
+C
+C     History:
+C     -------
+C       Version   Programmer         Date      Description
+C       -------   ----------         ----      -----------
+C       3.0       P. Terray (LODyC)  03/12/19  created
+C
+C _________________________________________________________________________________
+C
+C
+C
+C SPECIFICATIONS FOR ARGUMENTS
+C ____________________________
+C
+          character(len=*), intent(inout) :: string
+C
+          integer,     intent(in)    :: type
+C
+C
+C SPECIFICATIONS FOR LOCAL VARIABLES
+C __________________________________
+C
+         integer :: i
+         integer, parameter :: shift = ichar( 'a' ) - ichar( 'A' )
+C
+C
+C EXECUTABLE STATEMENTS
+C _____________________
+C
+        if ( type==1 ) then
+            do i = 1, len( string )
+                select case( string(i:i) )
+                  case( 'a':'i' , 'j':'r' , 's':'z' )
+                    string(i:i) = char( ichar(string(i:i)) - shift  )
+                end select
+            end do
+        else
+            do i = 1, len( string )
+                select case( string(i:i) )
+                  case( 'A':'I' , 'J':'R' , 'S':'Z' )
+                    string(i:i) = char( ichar(string(i:i)) + shift  )
+                end select
+            end do
+            if ( type==3 ) then
+                select case( string(1:1) )
+                  case( 'a':'i' , 'j':'r' , 's':'z' )
+                    string(1:1) = char( ichar(string(1:1)) - shift  )
+                end select
+            end if
+        end if
+        return
+C
+C
+C END OF SUBROUTINE case_change
+C _____________________________
+C
+        end
+C
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/getfpe.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/getfpe.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/getfpe.f	(revision 1677)
@@ -0,0 +1,89 @@
+      SUBROUTINE getfpe
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *getfpe*  - Signal handler
+C
+C     Purpose:
+C     -------
+C     getfpe is executed each time signal sigfpe is caught.
+C     Then code stops due to floating point exception error.
+C
+C**   Interface:
+C     ---------
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     Epicoa 920203 (1992) and OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/09/10  modified: new structure
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE getfpe  -  Level C'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' catch fpe error '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+C
+C
+C*    2. Abort simulation in case of floating point error
+C        ------------------------------------------------
+C
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $       ' ===>>> : fpe error has occurred in coupler'
+      WRITE (UNIT = nulou,FMT = *) 
+     $       ' ======   === =====                 ======='
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $       ' We STOP !!! Check non initialized variables'
+      CALL FLUSH (nulou)
+      CALL HALTE ('STOP in getfpe')
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/givfld.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/givfld.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/givfld.F	(revision 1677)
@@ -0,0 +1,690 @@
+      SUBROUTINE givfld (kindex, kfield, kiter)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *givfld* - writing routine
+C
+C
+C     Purpose:
+C     -------
+C     Write out coupling fields for iteration kiter
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *givfld (kindex, kfield, kiter)*
+C
+C     Input:
+C     -----
+C                kindex : current active fields index array
+C                kfield : current active fields total number
+C                kiter  : iteration number
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     PIPE_Send, CLIM_Export, SVIPC_write
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.1       L. Terray      96/08/07  modified: addition of cstate
+C                                          to prevent field transfer
+C       2.2       S. Valcke      97/08/22  added: introduction of SVIPC
+C       2.2       L. Terray      97/12/14  added: test on mode info +
+C                                          general cleaning
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* -----------------Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE 
+      USE mod_clim
+#endif
+      USE mod_parameter 
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_sipc
+      USE mod_unitncdf
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_unit
+      USE mod_hardware
+      USE mod_label
+      USE mod_calendar
+      USE mod_printing
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: info, 
+     $    iflag
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: idimlon, 
+     $    idimlat, ivarid
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ilongrd, 
+     $    ilatgrd
+      CHARACTER*8 clname, clfic, clstat, clwork, clstrg
+      CHARACTER*53 clabel
+      CHARACTER*32 cl_att_name
+      INTEGER (kind=ip_intwp_p) itime(3)
+      INTEGER (kind=ip_intwp_p) ist(3), icnt(3), ivardim(3)
+      INTEGER (kind=ip_intwp_p) idimtime, il_timevarid
+      INTEGER (kind=ip_intwp_p) il_nb_att, il_ind_att
+      CHARACTER*4 clon, clat
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Allocation and initialization
+C        -----------------------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE givfld  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Give coupling fields'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      infos = CLIM_Ok
+      itime(:)=0
+      ist(:)=0
+      icnt(:)=0
+      iflags = 0
+      istop = 0
+      imrca = 0
+      imrcb = 0
+      ALLOCATE (iflag(ig_nfield))
+      ALLOCATE (info(ig_nfield))
+      ALLOCATE (idimlon(ig_nfield))
+      ALLOCATE (idimlat(ig_nfield))
+      ALLOCATE (ivarid(ig_nfield))
+      ALLOCATE (ilongrd(ig_nfield))
+      ALLOCATE (ilatgrd(ig_nfield))      
+      CALL izero (iflag, ig_nfield)
+      CALL izero (info, ig_nfield)
+      idimlon(:)=0
+      idimlat(:)=0
+      ivarid(:)=0
+      ilongrd(:)=0
+      ilatgrd(:)=0
+C
+C
+C*    1.5 Create binary or netcdf output files for PIPE or NONE technique
+C        ----------------------------------------------------------------
+C
+      IF (kiter .eq. 0 .or. cchan .eq. 'PIPE') THEN
+      IF (cchan .eq. 'PIPE' .or. cchan .eq. 'NONE' ) THEN
+         DO 120 jf = 1, kfield
+           iloc = kindex(jf)
+           isamefic=0
+           DO 125 jj = 1, jf-1
+             ilocp=kindex(jj)
+             IF (nluout(iloc) .eq. nluout(ilocp)) THEN
+                 isamefic=isamefic+1
+                 nc_outid(jf) =  nc_outid(jj)
+             ENDIF
+ 125       END DO
+           IF (isamefic .lt. 1) THEN
+               iunit = nluout(iloc)
+               clfic = cficout(iloc)
+               IF (lncdfrst) THEN
+                   istatus=NF_CREATE(clfic, NF_CLOBBER, nc_outid(jf))
+                   IF (istatus .ne. NF_NOERR) THEN
+                      CALL prtout
+     $           ('Cannot create netcdf output file for field ',iloc,1)
+                      CALL HALTE('STOP in givfld') 
+                   ENDIF
+C
+C                  For each new file created define all possible 
+C                  dimensions and coordinate variables 
+C
+                   DO 130 jfint=1, kfield
+                     ilocint = kindex(jfint)
+                     isamedimlon = 0
+                     ilon = 0
+                     isamedimlat = 0
+                     ilat = 0
+                     isamegrd = 0
+                     igrd = 0
+C
+C                    Test if same output file 
+                     IF (nluout(ilocint) .eq. iunit) THEN
+C
+C                        Loop on all previous fields
+                         DO 135 jfintp=1, jfint-1
+                           ilocintp=kindex(jfintp)
+C
+C                          Test if same x dimension
+                           IF(nluout(ilocint) .eq. nluout(ilocintp)
+     $                .and. nlonaf(ilocint) .eq. nlonaf(ilocintp)) THEN
+                               isamedimlon = isamedimlon + 1
+                               idimlon(jfint) = idimlon(jfintp)
+                           ENDIF
+C
+C                          Test if same y dimension 
+                           IF(nluout(ilocint) .eq. nluout(ilocintp)
+     $                .and. nlataf(ilocint) .eq. nlataf(ilocintp)) THEN
+                               isamedimlat = isamedimlat + 1
+                               idimlat(jfint) = idimlat(jfintp)
+                           ENDIF
+C
+C                          Test IF same grid
+                           IF(nluout(ilocint).eq.nluout(ilocintp) .and.
+     $                     cficaf(ilocint) .eq. cficaf(ilocintp)) THEN
+                               isamegrd = isamegrd + 1
+                               ilongrd(jfint) = ilongrd(jfintp)
+                               ilatgrd(jfint) = ilatgrd(jfintp)
+                           ENDIF
+ 135                     CONTINUE
+C
+C                        Define x dimension if not already defined
+                         IF (isamedimlon .lt. 1) THEN
+                             ilon=ilon+1
+                             clon='lon'//char(ilon+48)
+                             CALL hdlerr(NF_DEF_DIM(nc_outid(jf), clon,
+     $                       nlonaf(ilocint), idimlon(jfint)),'givfld')
+                         ENDIF
+C
+C                        Define y dimension if not already defined
+                         IF (isamedimlat .lt. 1) THEN
+                             ilat=ilat+1
+                             clat='lat'//char(ilon+48)
+                             CALL hdlerr(NF_DEF_DIM(nc_outid(jf), clat,
+     $                       nlataf(ilocint), idimlat(jfint)),'givfld')
+                         ENDIF
+C
+C                        Define t dimension and variable at first 
+C                        time step if necessary
+                            CALL hdlerr(NF_DEF_DIM(nc_outid(jf),
+     $                           nc_invartime_name,NF_UNLIMITED,
+     $                           idimtime),'givfld')
+                            CALL hdlerr(NF_DEF_VAR(nc_outid(jf),
+     $                           nc_invartime_name,n_reaty,1,idimtime,
+     $                           il_timevarid),'givfld')
+                            icount = 80
+C
+C                        Copy time variable attributes
+C
+                         IF ( nitfn .gt. 0) THEN
+                            CALL hdlerr(NF_OPEN(cficinp(1),NF_NOWRITE,
+     $                           nc_inpid(1)),'givfld')
+                            CALL hdlerr(NF_INQ_VARNATTS(nc_inpid(1),
+     $                           nc_invartimeid, il_nb_att), 'givfld')
+                            DO il_ind_att=1, il_nb_att
+                                CALL hdlerr(NF_INQ_ATTNAME(nc_inpid(1),
+     $                               nc_invartimeid, il_ind_att,
+     $                               cl_att_name), 'givfld')
+                                CALL hdlerr(NF_COPY_ATT(nc_inpid(1),
+     $                               nc_invartimeid, cl_att_name,
+     $                               nc_outid(jf), il_timevarid)
+     $                               , 'givfld')
+                            END DO
+                            CALL hdlerr(NF_CLOSE(nc_inpid(1)))
+                         ENDIF
+C
+C                        Create coord. variable IF not already created
+                         IF (isamegrd .lt. 1) THEN
+                             ivardim(1)=idimlon(jfint)
+                             ivardim(2)=idimlat(jfint)
+                             clwork = cficaf(jfint)
+                             icount = ilenstr(clwork,jpeight)
+                             clstrg = clwork(1:icount)//cglonsuf
+                             CALL hdlerr(NF_DEF_VAR(nc_outid(jf),
+     $               clstrg,n_reaty,2,ivardim,ilongrd(jfint)),'givfld')
+                             clstrg = clwork(1:icount)//cglatsuf
+                             CALL hdlerr(NF_DEF_VAR(nc_outid(jf), 
+     $               clstrg,n_reaty,2,ivardim,ilatgrd(jfint)),'givfld')
+                         ENDIF
+                     ENDIF
+ 130               CONTINUE
+               ELSE
+                   OPEN (UNIT = iunit,FILE = clfic,STATUS = 'UNKNOWN',
+     $             FORM = 'UNFORMATTED',IOSTAT = iost)
+                   IF (iost .ne. 0) THEN
+                       CALL prtout
+     $           ('Cannot create binary output file for field ',iloc,1)
+                       CALL HALTE('STOP in givfld') 
+                   ENDIF
+               ENDIF
+           ENDIF
+
+C
+C* Create the jf netcdf variables
+C
+           IF (lncdfrst) THEN
+               ivardim(1)=idimlon(jf)
+               ivardim(2)=idimlat(jf)
+C                 IF ( nitfn .gt. 0) THEN
+                     ivardim(3)=idimtime
+                     CALL hdlerr(NF_DEF_VAR(nc_outid(jf), cnamout(iloc), 
+     $                    n_reaty, 3, ivardim, ivarid(jf)), 'givfld')
+C                 ELSE
+C                    CALL hdlerr(NF_DEF_VAR(nc_outid(jf), cnamout(iloc), 
+C    $                    n_reaty, 2, ivardim, ivarid(jf)), 'givfld')
+C                 ENDIF
+           ENDIF
+ 120     CONTINUE
+C
+C* Define header if info mode is on :
+C  experiment name, initial date, iteration number, time since start
+C
+         IF (lmodinf) THEN 
+             itime(1) = ndate
+             itime(2) = kiter
+             itime(3) = kiter * nstep
+             IF (nlogprt .GE. 2) THEN
+                 WRITE (UNIT = nulou,FMT = *) 
+     $              ' Encapsulated data for current field is :'
+                 CALL prcout ('Experiment name', cjobnam, 1)
+                 CALL prtout ('Initial date', itime(1), 2)
+                 CALL prtout ('Iteration number', itime(2), 2)
+                 CALL prtout ('Time since start', itime(3), 2)
+             ENDIF
+         ENDIF
+C
+         IF (lncdfrst) THEN
+C     
+C            Loop on all fields for this iteration
+             DO 140 jf = 1, kfield
+               iloc=kindex(jf)
+               isamefic=0
+C
+C              Test IF define mode has been already left. 
+               DO 145 jj = 1, jf-1
+                 IF (nc_outid(jf) .eq. nc_outid(jj)) THEN
+                     isamefic=isamefic+1
+                 ENDIF
+ 145           CONTINUE
+C
+               IF (isamefic .lt. 1) THEN
+C
+C*                 Put header as global attribute IF lmodinf
+                   WRITE(nulou,*)'lmodinf=', lmodinf
+                   IF (lmodinf) THEN
+                      CALL hdlerr(NF_PUT_ATT_TEXT(nc_outid(jf),
+     $                NF_GLOBAL,'Experiment_name',4,cjobnam),'givfld')
+                      CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
+     $                ,'Initial_date',NF_INT,1,itime(1)),'givfld') 
+                      CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
+     $                ,'Iteration_number',NF_INT,1,itime(2)),'givfld')
+                      CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
+     $                ,'Time_since_start',NF_INT,1,itime(3)),'givfld')
+                   ENDIF
+C
+C*                 Leave define mode for netcdf files
+                   istatus=NF_ENDDEF(nc_outid(jf))
+                   IF(istatus .ne. NF_NOERR) THEN
+                       CALL prtout
+     $   ('Cannot leave define mode for output file for field ',iloc,1)
+                       CALL HALTE('STOP in givfld') 
+                   ENDIF    
+               ENDIF
+C
+C              Test IF coordinate variables have already been put. 
+               isamegrd = 0
+               iadrnew = nadrnew_grid(jf)
+               isiznew = nsiznew(jf)
+               DO 155 jj = 1, jf-1
+                 ilocp=kindex(jj)
+                 IF (nluout(iloc) .eq. nluout(ilocp) .and. cficaf(iloc)
+     $               .eq. cficaf(ilocp)) isamegrd=isamegrd+1
+ 155           CONTINUE
+C
+C              If not, put coordinate variable to file jf
+               IF (isamegrd .lt. 1) THEN
+                   ist(1)=1 ; ist(2)=1
+                   icnt(1)=nlonaf(iloc) ; icnt(2)=nlataf(iloc)
+                   IF (n_reaty .eq. NF_FLOAT) THEN
+                       istatus=NF_PUT_VARA_REAL 
+     $                    (nc_outid(jf),ilongrd(jf),ist, icnt,
+     $                     xgrnew(iadrnew:iadrnew+isiznew-1))
+
+                   ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                       istatus=NF_PUT_VARA_DOUBLE 
+     $                    (nc_outid(jf),ilongrd(jf),ist, icnt,
+     $                     xgrnew(iadrnew:iadrnew+isiznew-1))
+                   ENDIF
+                   IF (n_reaty .eq. NF_FLOAT) THEN
+                       istatus=NF_PUT_VARA_REAL 
+     $                    (nc_outid(jf),ilatgrd(jf),ist, icnt,
+     $                     ygrnew(iadrnew:iadrnew+isiznew-1))
+
+                   ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                       istatus=NF_PUT_VARA_DOUBLE 
+     $                    (nc_outid(jf),ilatgrd(jf),ist, icnt,
+     $                     ygrnew(iadrnew:iadrnew+isiznew-1))
+                   ENDIF
+               ENDIF
+ 140         CONTINUE
+         ENDIF
+C
+      ENDIF
+C
+      ENDIF
+C
+C*    2. Loop on active fields for iteration kiter
+C        -----------------------------------------
+C
+!$omp parallel do default (shared)
+!$omp+ private (jf,iloc,iadrnew,isiznew,clname,ilabel)
+!$omp+ private (clabel,iunit,clstat)
+!$omp+ reduction (+:infos)
+
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+        iloc = kindex(jf)
+        iadrnew = nadrnew(iloc)
+        isiznew = nsiznew(iloc)
+        clname = cnamout(iloc)
+        ilabel = numlab(iloc)
+        clabel = cfldlab(ilabel)
+        iunit = nluout(iloc)
+        clstat = cstate(iloc)
+C
+C* Test if field must be exported
+C
+        IF (clstat .EQ. 'EXPORTED') THEN 
+C
+C* Print field name
+C
+           IF (nlogprt .GE. 1) THEN
+              CALL prcout('Writing of field : ', clname, 2)
+              CALL prcout('Field definition : ', clabel, 2)
+           ENDIF
+
+C
+C* - Give coupling fields
+C
+C* PIPE or NONE case
+C
+           IF (cchan .EQ. 'PIPE' .OR. cchan .EQ. 'NONE') THEN
+C     
+              IF (lncdfrst) THEN
+CEM
+C  Get variables ID
+CEM
+                 istatus=NF_INQ_VARID(nc_outid(jf),clname,
+     $                   ivarid(jf))
+                 istatus=NF_INQ_VARID(nc_outid(jf),nc_invartime_name,
+     $                   il_timevarid)
+                 ist(1)=1 ; ist(2)=1 ; ist(3)=1+kiter
+                 icnt(1)=nlonaf(iloc) ; icnt(2)=nlataf(iloc)
+                 icnt(3)=1
+                 IF (n_reaty .eq. NF_FLOAT) THEN
+                    CALL hdlerr(NF_PUT_VARA_REAL
+     $                   (nc_outid(jf),il_timevarid,ist(3),
+     $                   icnt(3),r_time_val), 'givfld')
+                    istatus=NF_PUT_VARA_REAL
+     $                   (nc_outid(jf),ivarid(jf),ist, icnt,
+     $                   fldnew(iadrnew:iadrnew+isiznew-1))
+                    IF (istatus .ne. 0)  THEN
+                       iflag(jf) = istatus
+                       iflags= iflags + 1
+                    ENDIF
+                    
+                 ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                    CALL hdlerr(NF_PUT_VARA_DOUBLE
+     $                   (nc_outid(jf),il_timevarid,ist(3),
+     $                    icnt(3),rtime_val), 'givfld')
+                    istatus=NF_PUT_VARA_DOUBLE 
+     $                   (nc_outid(jf),ivarid(jf),ist, icnt,
+     $                   fldnew(iadrnew:iadrnew+isiznew-1))
+                    IF (istatus .ne. 0)  THEN
+                       iflag(jf) = istatus
+                       iflags= iflags + 1
+                    ENDIF
+                 ENDIF
+              ELSE
+C* Write new field on unit iunit with header if required
+C 
+                 IF (lmodinf) THEN 
+                    CALL locwrith (clname, cjobnam, itime, 
+     $                   fldnew(iadrnew), isiznew, iunit, iflag(jf))
+                 ELSE 
+                    CALL locwrite (clname, fldnew(iadrnew), isiznew, 
+     $                   iunit, iflag(jf))
+                 ENDIF 
+                 iflags = iflags + iflag(jf)
+              ENDIF
+          ELSE IF (cchan .EQ. 'SIPC' .OR. cchan .EQ. 'GMEM') THEN
+C
+C* SIPC case
+C
+#if defined use_comm_SIPC || defined use_comm_GMEM
+C
+              ipbytecha=kind('A')
+              ipbyteint=kind(itime)
+              ipbyterea=kind(fldnew)
+C
+C* Write encapsulated infos in field-specific shared memory pool
+C
+              IF (lmodinf) THEN 
+                 isizeout = 3*ipbytecha
+                 CALL SVIPC_write(mpoolidou(iloc), cjobnam 
+     $                , isizeout, imrca)
+                 isizeout = 3*ipbyteint
+                 CALL SVIPC_write(mpoolidou(iloc), itime 
+     $                ,isizeout,imrcb)
+C
+C* Find error if any
+C
+                 IF (imrca .LT. 0 .OR. imrcb .LT. 0) THEN
+                    CALL prcout 
+     $  ('Problem in writing encapsulated infos for field', clname, 1)
+                    istop = 1
+                 ENDIF 
+                 IF (nlogprt .GE. 2) THEN
+                    CALL prcout
+     $    ('Wrote encapsulated infos in pool for field',clname,1)
+                 ENDIF 
+              ENDIF 
+C
+C* Write part of macro array in field-specific shared memory pool
+C
+              isizeout = isiznew * ipbyterea
+              IF (nlogprt .GE. 2) THEN
+                 WRITE(UNIT = nulou, FMT = *) 
+     $                'Writing field data to pool = ',mpoolidou(iloc)
+              ENDIF
+              CALL SVIPC_write(mpoolidou(iloc),
+     $             fldnew(iadrnew), isizeout, imrc)
+C
+C* Find error and stop if any
+C
+              IF (imrc .LT. 0) THEN
+                 CALL prcout
+     $               ('Problem in writing field in SHM pool:',clname,1) 
+                 istop = 1
+              ELSE IF (nlogprt .GE. 2) THEN
+                 CALL prcout
+     $                ('Wrote field in SHM pool:', clname, 1)
+              ENDIF
+C
+C* CLIM case
+C
+#endif
+          ELSE IF (cchan .EQ. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE 
+C
+C* Write new field on port clname
+C
+!$omp critical
+              CALL CLIM_Export 
+     $            (ig_portout_id(iloc), kiter*nstep, 
+     $            fldnew(iadrnew), info(jf))
+              infos = infos + info(jf)
+!$omp end critical
+#endif
+          ELSE
+              CALL prcout 
+     $            ('Wrong CHANNEL option for field', clname, 1)
+          ENDIF
+      ELSE IF (clstat .EQ. 'AUXILARY') THEN 
+          iflag(jf) = 0
+          info(jf) = 0
+      ENDIF
+ 210  CONTINUE
+C
+      IF (cchan .EQ. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
+C*
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE 
+C*    Stop if problem in writing in CLIM case
+C
+          IF (infos .NE. CLIM_Ok) THEN 
+              DO 220 jf = 1, kfield
+                IF (info(jf) .NE. CLIM_Ok) THEN
+                    CALL prcout
+     $                  ('WARNING: problem in writing field on port',
+     $                  clname, 1)
+                    CALL prtout
+     $                  ('error code number', info(jf), 2)
+                ENDIF
+ 220          CONTINUE
+              CALL HALTE ('STOP in givfld') 
+          ENDIF
+C
+#endif
+      ELSE IF (cchan .EQ. 'PIPE' .or. cchan .eq. 'NONE') THEN
+#if defined use_comm_PIPE || defined use_comm_NONE
+C*    Stop if problem in writing in PIPE or NONE case
+C
+          IF (iflags .NE. 0) THEN 
+              DO 230 jf = 1, kfield
+                IF (iflag(jf) .NE. 0) THEN
+                    iloc = kindex(jf)
+                    iunit = nluout(iloc)
+                    clname = cnamout(iloc)
+                    CALL prcout
+     $                  ('WARNING: problem in writing field',
+     $                  clname, 1)
+                    CALL prtout
+     $                  ('Error writing on logical unit', iunit, 2)
+                ENDIF
+ 230          CONTINUE
+              CALL HALTE ('STOP in givfld')
+          ENDIF
+C
+#endif
+      ELSE IF (cchan .EQ. 'SIPC' .or. cchan .eq. 'GMEM') THEN
+#if defined use_comm_SIPC || defined use_comm_GMEM
+C*    Stop if problem in writing in SIPC or GMEM case
+C
+          IF (istop .NE. 0) CALL HALTE ('STOP in givfld')
+#endif
+C
+      ENDIF
+C
+C*    3. PIPE Case: flush data files and send message
+C        --------------------------------------------
+C
+      IF (cchan .EQ. 'PIPE' .or. cchan .eq. 'NONE') THEN
+C 
+          DO 310 jf = 1, kfield
+C
+C* Assign local variables
+C
+            iloc = kindex(jf)
+            clname = cnamout(iloc)
+            iunit = nluout(iloc)
+            clfic = cficout(iloc)
+            clstat = cstate(iloc)
+C
+C* Test if field must be exported
+C
+            IF (clstat .EQ. 'EXPORTED') THEN 
+C
+C* Close data file
+C
+                iloc=kindex(jf)
+                isamefic=0
+                DO 3005 jj = 1, jf-1
+                  IF (nc_outid(jf) .eq. nc_outid(jj)) THEN
+                      isamefic=isamefic+1
+                  ENDIF
+ 3005           CONTINUE
+C
+                IF (isamefic .lt. 1) THEN
+                    IF (lncdfrst) THEN
+                      IF (kiter.eq.nitfn) then
+                        CALL hdlerr(NF_CLOSE(nc_outid(jf)), 'givfld')
+                     ENDIF
+                    ELSE
+                        CLOSE(UNIT = iunit, ERR = 3010, IOSTAT = ios)
+                        IF (nlogprt .GE. 2) THEN
+                            WRITE(UNIT = nulou,FMT = 3100) iunit,clfic
+                        ENDIF
+ 3010                   CONTINUE
+                        IF (ios .NE. 0) THEN
+                            CALL prtout('Problem in closing unit',
+     $                          iunit, 2)
+                            CALL prtout('Error message nbr is= ',ios,2)
+                            CALL HALTE('STOP in givfld')
+                        ENDIF 
+                    ENDIF
+                ENDIF
+C
+C* Send message on pipe clname for PIPE technique
+C
+#ifdef use_comm_PIPE
+                CALL PIPE_Send (clname, kiter)
+#endif
+            ELSE IF (clstat .EQ. 'AUXILARY' .AND. nlogprt .GE. 2) THEN 
+                WRITE(UNIT = nulou, FMT = 3300) clname, clfic
+            ENDIF 
+ 310      CONTINUE
+      ENDIF
+ 3100 FORMAT(/,5X,' Unit ',I2,' has been disconnected from file ',A8)
+ 3200 FORMAT(/,5X,' Unit ',I2,' has been reconnected to file ',A8)
+ 3300 FORMAT(/,5X,' Auxilary field ',A8,' is not written on file ',A8)
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine givfld ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      DEALLOCATE (info)
+      DEALLOCATE (iflag)
+      DEALLOCATE (idimlon)
+      DEALLOCATE (idimlat)
+      DEALLOCATE (ivarid)
+      DEALLOCATE (ilongrd)
+      DEALLOCATE (ilatgrd)
+      RETURN
+      END
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/glored.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/glored.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/glored.f	(revision 1677)
@@ -0,0 +1,175 @@
+      SUBROUTINE glored (pzgg, pworkgr, klon, klat, ktronca)
+C*****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *glored* - Global gaussian grid transformation 
+C
+C     Purpose:
+C     -------
+C     Linear interpolation of field from full gaussian grid to reduced grid
+C
+C     N.B: It is assumed that a preprocessing of the field on the full grid
+C          was done to allocate ocean values to land points as no mask is used
+C          in this routine. 
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *glored (pzgg, pworkgr, klon, klat, ktronca)*
+C
+C     Input:
+C     -----
+C                pzgg    : field on global grid (real 2D)
+C                pworkgr : array to store field on global grid (real 2D)
+C                klon    : number of longitudes of global grid
+C                klat    : number of latitudes of both grids
+C                ktronca : truncature of gaussian grid
+C                   
+C     Output:
+C     ------
+C                pzgg: field on reduced grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     inip
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/09/01  modified
+C       2.3       L. terray      99/03/01  bug corrected: inip DIMENSION
+C       2.3       S. Valcke      99/03/16  modified for T213 and T319
+C       2.3       S. Valcke      99/03/26  changed troncature for number of 
+C                                          latitude between equator and pole
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_gauss
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+
+      REAL (kind=ip_realwp_p) pzgg(klon,klat), pworkgr(klon*klat)
+      INTEGER (kind=ip_intwp_p) inip(320)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE glored  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Go from global to reduced grid'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      CALL izero(inip,320)
+C
+C
+C*    2. Full to reduced linear interpolation  
+C        ------------------------------------
+C
+C
+C* get number of longitudes by latitude circle
+C
+      IF (ktronca .EQ. 16) THEN
+          DO 210 ji = 1, ktronca
+            inip(ji) = ninip16(ji)
+ 210      CONTINUE 
+        ELSE IF (ktronca .EQ. 24)  THEN 
+          DO 220 ji = 1, ktronca
+            inip(ji) = ninip24(ji)
+ 220      CONTINUE
+        ELSE IF (ktronca .EQ. 32)  THEN 
+          DO 230 ji = 1, ktronca 
+            inip(ji) = ninip32(ji)
+ 230      CONTINUE 
+        ELSE IF (ktronca .EQ. 48)  THEN 
+          DO 240 ji = 1, ktronca 
+            inip(ji) = ninip48(ji)
+ 240      CONTINUE    
+        ELSE IF (ktronca .EQ. 80)  THEN 
+          DO 250 ji = 1, ktronca 
+            inip(ji) = ninip80(ji)
+ 250      CONTINUE 
+        ELSE IF (ktronca .EQ. 160)  THEN 
+          DO 255 ji = 1, ktronca 
+            inip(ji) = ninip160(ji)
+ 255      CONTINUE 
+        ELSE
+          CALL prtout
+     $          ('WARNING!!! Oasis cannot treat this grid with 2*NO 
+     $          latitude lines with NO = ', ktronca, 2)
+          CALL prtout('Implement data for NO =', ktronca, 2)
+          CALL HALTE('STOP in glored')
+      ENDIF
+C
+C* Extend inip array to both hemispheres
+C
+      DO 260 ji = klat/2 + 1, klat
+        inip(ji) = inip(klat - ji + 1)
+ 260  CONTINUE
+C
+C* Do the interpolation global to reduced
+C
+      indice = 0
+      DO 270 jk = 1, klat
+        DO 280 ji = 1, inip(jk)
+          zxi = 1 + ((ji - 1) * klon) / FLOAT(inip(jk))
+          im = INT(zxi)
+          zdx = zxi - im
+          im = 1 + MOD(im + klon - 1,klon)
+          ip = 1 + MOD(im,klon)
+          pworkgr(indice + ji) = pzgg(im,jk) * (1.-zdx) 
+     $                      + pzgg(ip,jk) * zdx
+ 280    CONTINUE
+        indice = indice + inip(jk)
+ 270  CONTINUE
+C
+C* Assign reduced grid values to array pzgg
+C
+      DO 290 jj = 1, klat
+        DO 295 ji = 1, klon
+         pzgg(ji,jj) = pworkgr(klon*(jj-1)+ji) 
+ 295   CONTINUE 
+ 290  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine glored ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+ 
Index: CPL/oasis3/trunk/src/mod/oasis3/src/grstat.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/grstat.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/grstat.f	(revision 1677)
@@ -0,0 +1,176 @@
+      SUBROUTINE grstat (pcorx, pcory, psgr, kmsk, kngx, kngy, cdtyp,
+     $                   pdr, psr, phhi, kvma)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL T *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *grstat* - Statistic routine
+C
+C     Purpose:
+C     -------
+C     Given a grid, calculate the average grid square size,
+C     the total surface and the inverse of sum of surface elements squared.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *grstat (pcorx, pcory, psgr, kmsk, kngx, kngy
+C                        pdr, psr, phhi, kvma)*
+C
+C     Input:
+C     -----
+C                pcorx : the grid points longitude (real 2D)
+C                pcory : the grid points latitude (real 2D)
+C                psgr  : surface elements (real 2D)
+C                kmsk  : the grid mask (integer 2D)
+C                kngx  : the grid size in direction 1
+C                kngy  : the grid size in direction 2
+C                cdtyp : type of source grid  
+C                kvma  : integer value of the mask 
+C
+C     Output:
+C     ------
+C                pdr   : the average grid square size
+C                psr   : the total surface
+C                phhi  : inverse of sum of surface elements squared
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     sqdis
+C
+C     Reference:
+C     ---------
+C     O. Thual, Simple ocean-atmosphere interpolation. 
+C               Part A: The method, EPICOA 0629 (1992)
+C               Part B: Software implementation, EPICOA 0630 (1992)
+C
+C     See also OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.1       O. Thual       94/01/01  created
+C       2.0       L. Terray      95/12/26  modified : to suit OASIS 2.0
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pcorx(kngx,kngy), pcory(kngx,kngy)
+      REAL (kind=ip_realwp_p) psgr(kngx,kngy)
+      INTEGER (kind=ip_intwp_p) kmsk(kngx,kngy)
+      CHARACTER*1 cdtyp
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*1 cltyp
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C   
+      ivma = kvma
+      cltyp = cdtyp
+C
+C
+C*    2. Interdistances only for unmasked points
+C        ---------------------------------------
+C
+C* Average distance squared in x-direction
+C
+      ztot2 = 0.
+      icount = 0
+      DO 210 j2 = 1, kngy
+      zsum = 0.
+      DO 220 j1 = 1, kngx-1
+        IF (kmsk(j1,j2) .NE. ivma) THEN
+            iadd = 0
+            IF (cltyp .ne. 'D') iadd = 1
+C* For reduced grid, calculate distance only in the x-direction between
+C* points located on same latitude circle.
+            IF (cltyp .eq. 'D' .and. pcory(j1,j2) .eq. pcory(j1+1,j2))
+     $          iadd = 1
+C* For U grid, the average distance will be calculated based on all
+C* consecutive points.
+            IF (iadd .eq. 1) then
+                zdis = sqdis(pcorx(j1,j2), pcory(j1,j2),
+     $                   pcorx(j1+1,j2), pcory(j1+1,j2))
+                icount = icount + iadd
+                zsum = zsum + zdis
+            ENDIF
+        ENDIF
+ 220  CONTINUE
+      ztot2 = ztot2 + zsum
+ 210  CONTINUE
+      WRITE(nulan, *)'In grstat, icount= ', icount
+      ztot2 = ztot2 / float(icount)
+C
+C* Average distance squared in y-direction
+C
+      IF ((cltyp .eq. 'D') .or. (cltyp .eq. 'U')) THEN
+          pdr = ztot2
+          ztot1 = 0.
+      ELSE
+          ztot1 = 0.
+          icount = 0
+          DO 230 j1 = 1, kngx
+            zsum = 0.
+            DO 240 j2 = 1, kngy-1
+              IF(kmsk(j1,j2) .NE. ivma) THEN
+                  zdis = sqdis(pcorx(j1,j2), pcory(j1,j2),
+     $                   pcorx(j1,j2+1), pcory(j1,j2+1))
+                  icount = icount + 1
+                  zsum = zsum + zdis
+              ENDIF
+ 240        CONTINUE
+            ztot1 = ztot1 + zsum
+ 230      CONTINUE
+          ztot1 = ztot1 / float(icount)
+C
+C* Get average grid square size
+C
+          pdr = (ztot1 + ztot2) / 2.
+      ENDIF
+
+C
+C
+C*    3. Surface and <hh>^-1
+C        -------------------
+C
+      zsurf = 0.
+      zhhi = 0.
+      DO 310 j2 = 1, kngy
+        DO 320 j1 = 1, kngx
+          IF (kmsk(j1,j2) .NE. ivma) THEN
+              zsurf = zsurf + psgr(j1,j2)
+              zhhi = zhhi + psgr(j1,j2) * psgr(j1,j2)
+          ENDIF
+ 320    CONTINUE 
+ 310  CONTINUE
+C
+C* Get total surface and inverse of sum of elements squared
+C
+      psr = zsurf
+      IF (zhhi .ne. 0.) phhi = 1. / zhhi
+C
+C
+C*    4. End of routine
+C        --------------
+C 
+      RETURN       
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/halte.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/halte.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/halte.F	(revision 1677)
@@ -0,0 +1,108 @@
+      SUBROUTINE halte (cdtext)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *halte*  - Abort the program
+C
+C     Purpose:
+C     -------
+C     Print an error message to standard output and abort the coupler
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *halte (cdtext)*
+C
+C     Input:
+C     -----
+C                cdtext   : character string to be printed
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS 2.2 manual (1997) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       S. Valcke      97/11/18  created
+C       2.3       L. Terray      99/02/24  modified: X format for NEC
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+      USE mod_hardware
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_comclim
+#endif
+C
+C* ---------------------------- Argument declarations ----------------------
+C
+      CHARACTER*(*) cdtext
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER cpbase
+      CHARACTER*10 cprpt, cpdots
+      CHARACTER*69 cline
+      PARAMETER ( cpbase = '-' )
+      PARAMETER ( cprpt = '* ===>>> :' )
+      PARAMETER ( cpdots = '  ------  ' )
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Print text 
+C        ----------
+C
+          cline = ' '
+          ilen = len(cdtext)
+          DO 110 jl = 1, ilen
+            cline(jl:jl) = cpbase
+ 110      CONTINUE
+          WRITE(UNIT = nulou,FMT='(/,A,1X,A)') cpdots, cline
+          WRITE(UNIT = nulou,FMT='(/,A,1X,A,/)') cprpt, cdtext
+          WRITE(UNIT = nulou,FMT='(A,1X,A,/)')cpdots, cline
+C
+C
+C*    2. Close the coupler output
+C        ------------------------
+C
+          CLOSE(nulou)
+C
+C
+C*    3. Abort the coupler
+C        -----------------
+C
+#if defined use_comm_MPI1 || defined use_comm_MPI2
+      IF (cchan .eq. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
+          CALL MPI_ABORT (mpi_comm, 0, ierror)
+          IF (ierror /= CLIM_Ok) THEN
+              WRITE (*,'(a)') ' MPI_ABORT failed'
+              WRITE (*,'(a,i4)') ' Error =  ', ierror
+              CALL abort
+          ENDIF
+      ENDIF
+#endif
+#if defined use_comm_SIPC || defined use_comm_GMEM || defined use_comm_PIPE || defined use_comm_NONE
+      CALL abort
+#endif
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/hdlerr.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/hdlerr.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/hdlerr.f	(revision 1677)
@@ -0,0 +1,13 @@
+      subroutine hdlerr(istatus, cd_routine)
+      USE mod_kinds_oasis
+      USE mod_unit
+      integer (kind=ip_intwp_p) :: istatus
+      CHARACTER*(*) cd_routine
+      INCLUDE 'netcdf.inc'
+      if (istatus .ne. NF_NOERR) then
+          WRITE(nulou,*) NF_STRERROR(istatus)
+          CALL prcout('STOP in ', cd_routine, 2)
+          CALL halte('STOP')
+      endif
+      return
+      end
Index: CPL/oasis3/trunk/src/mod/oasis3/src/icoor.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/icoor.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/icoor.f	(revision 1677)
@@ -0,0 +1,70 @@
+      FUNCTION icoor (kind, kimax)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *icoor*  - Search function
+C
+C     Purpose:
+C     -------
+C     Given an index value, kind, for a 2D array which has kimax rows, 
+C     this function returns the row number
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *icoor (kind, kimax)*
+C
+C     Input:
+C     -----
+C                kind   : index (integer)
+C                kimax  : number of rows (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.1       R. Sutton      95/11/25  Created
+C       2.0       L. Terray      95/12/26  Modified: to suit OASIS 2.0
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) icoor
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the row number 
+C        -------------------
+C      
+      icoor = kind - ((kind-1) / kimax) * kimax
+C
+C* End of function
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/idivmax.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/idivmax.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/idivmax.f	(revision 1677)
@@ -0,0 +1,80 @@
+      FUNCTION idivmax (ka, kna, kguess)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *idivmax*  - Search function
+C
+C     Purpose:
+C     -------
+C     Search the greatest common divisor of all elements of an integer array
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *idivmax (ka, kna, kguess)*
+C
+C     Input:
+C     -----
+C                ka     : array to be searched (integer 1D)
+C                kna    : array dimension (integer)
+C                kguess : initial guess for the divisor (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) idivmax, ka(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Check if kguess divides all ka elements
+C        ---------------------------------------
+C
+      DO 110 jk = kguess, 1, -1
+        IF (mod(kguess,jk) .EQ. 0) THEN
+            DO 120 ji = 1, kna
+              IF (mod(ka(ji),jk) .NE. 0) GO TO 110
+ 120        CONTINUE
+            GO TO 130
+        ENDIF 
+ 110  CONTINUE
+ 130  idivmax = jk
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/ilenstr.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/ilenstr.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/ilenstr.f	(revision 1677)
@@ -0,0 +1,74 @@
+      FUNCTION ilenstr (cdstr, knstr)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *ilenstr*  - Search function
+C
+C     Purpose:
+C     -------
+C     Find the length of a character string (no blank characters)
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *ilenstr (cdstr, knstr)*
+C
+C     Input:
+C     -----
+C                cdstr : string to be searched (char string)
+C                knstr : total length of the string (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     nextch, nextbl
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      CHARACTER*1 cdstr
+      DIMENSION cdstr(knstr)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Find character string length
+C        ----------------------------
+C
+      ii = nextch (cdstr, 1, knstr)
+      ii = nextbl (cdstr, ii, knstr)
+      ii = ii - 1
+      ilenstr = ii
+C
+C
+C*    2. End of function
+C        ---------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/imaxim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/imaxim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/imaxim.f	(revision 1677)
@@ -0,0 +1,78 @@
+      FUNCTION imaxim (ka, kna)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *imaxim*  - Search function
+C
+C     Purpose:
+C     -------
+C     Search the maximum of the elements of an integer array
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *imaxim (ka, kna)*
+C
+C     Input:
+C     -----
+C                ka     : array to be searched (integer 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) imaxim, ka(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the maximum 
+C        ----------------
+C
+      itemp = 0
+      IF (kna .LT. 1) GO TO 110
+      itemp = ka(1)
+      IF (kna .LT. 2) GO TO 110
+      DO 120 ja = 2, kna
+        IF (ka(ja) .GT. itemp) itemp = ka(ja)
+ 120  CONTINUE
+ 110  CONTINUE
+      imaxim = itemp
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/iminim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/iminim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/iminim.f	(revision 1677)
@@ -0,0 +1,73 @@
+      FUNCTION iminim (ka, kna)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *iminim*  - Search function
+C
+C     Purpose:
+C     -------
+C     Search the minimum of the elements of an integer array
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *iminim (ka, kna)*
+C
+C     Input:
+C     -----
+C                ka     : array to be searched (integer 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) iminim, ka(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the minimum 
+C        ----------------
+C
+      itemp = 0
+      IF (kna .LT. 1) GO TO 110
+      itemp = ka(1)
+      IF (kna .LT. 2) GO TO 110
+      DO 100 ja = 2, kna
+        IF (ka(ja) .LT. itemp) itemp = ka(ja)
+ 100  CONTINUE
+ 110  CONTINUE
+      iminim = itemp
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inicmc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inicmc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inicmc.F	(revision 1677)
@@ -0,0 +1,671 @@
+      SUBROUTINE inicmc
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inicmc*  - Initialize coupled mode communication for coupler
+C
+C     Purpose:
+C     -------
+C     Use either PIPE, CLIM, SIPC or GMEM library to start communication with
+C     the models being coupled. The PIPE library uses named pipes(fifo)
+C     while CLIM uses message passing library MPI-1 or MPI-2.
+C     The SIPC library uses shared memory segments based on system V IPC.
+C     The GMEM library uses the global memory concept of NEC machines.
+C     In cases SIPC, GMEM or PIPE, signal handling is implemented to trap 
+C     oasis or child status changes.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inicmc*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     (CLIM-PIPE-SIPC)_Init, (CLIM-PIPE-SIPC)_Define, (CLIM-PIPE-SIPC)_Stepi, 
+C     CLIM_Start, chksgc
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (2000)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/09/01  modified : new structure
+C       2.1       L. Terray      96/09/03  mofified : norm DOCTOR (loop
+C                                          index jp --> jl)
+C       2.2       S. Valcke      97/06/20  added: introduction of SVIPC
+C       2.2       L. Terray      97/09/20  general cleaning + call chksgc
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  added: GMEM branch
+C       2.4       S. Valcke      2K/05/01  added: llmodel for CLIM/MPI2
+C       2.5       S. Valcke      2K/09/04  Remove cmach
+C       2.5       S. Valcke      2K/09/08  -Remove llmodel
+C                                          -Modified CALL to CLIM_Init
+C       2.5       J. Latour      01/11/28  added : MPI1 use of mpirun
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_clim
+      USE mod_clim_def
+      USE mod_comclim
+#endif
+      USE mod_parameter
+      USE mod_parallel
+      USE mod_string
+      USE mod_unitncdf
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+      USE mod_analysis
+      USE mod_label
+      USE mod_gauss
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+#include <mpif.h>
+#endif
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) il_dimid(2)
+      INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: info 
+      INTEGER (kind=ip_intwp_p) iparal(3)
+      INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: il_sizold,
+     $    il_siznew, il_maxaux
+      CHARACTER*8 clpinp, clpout
+      CHARACTER*8 clwork, clstrg
+      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cl_auxaf, cl_auxbf
+      INTEGER (kind=ip_intwp_p) :: il_ibyt, il_bufsendsize, 
+     $    il_bufsendsizebyt, il_varid, ii, io_size, integer_io_size
+      INTEGER (kind=ip_intwp_p) :: integer_byte_size
+      REAL(kind=ip_double_p) rl_testvar
+c
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Allocation and initializations 
+C        ------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE inicmc  -  Level C'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Process stuff initialization'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      iparal(:)=0
+C
+C* Set up signal handling
+C
+      CALL chksgc
+C
+C* Allocate and initialize error codes (only if all fields aren't exchanged 
+C  directly)
+C
+      IF (lg_oasis_field) THEN
+         ALLOCATE(info(ig_nfield))
+         CALL izero (info, ig_nfield)
+      ENDIF
+   
+C
+c
+C* PIPE initialization
+c     
+#ifdef use_comm_PIPE
+C     
+C* Open pipes between models to exchange checking data
+C
+      infos = 0
+      CALL PIPE_Init (cjobnam, cmodnam, ig_nmodel, infos)
+      IF (infos .NE. 0) THEN 
+         WRITE (UNIT = nulou,FMT = *) 
+     $        ' WARNING : Problem with model pipe initialization'
+         WRITE (UNIT = nulou,FMT = *)
+     $        ' =======   Error code number = ',infos
+         CALL HALTE('STOP in inicmc')
+      ENDIF
+C     
+C* SVIPC or GMEM initialization
+C     
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+C     
+C* Open shared memory pools used by models to exchange initial infos 
+C     
+      infos = 0
+      CALL SIPC_Init (cjobnam, cmodnam, ig_nmodel, infos)
+      IF (infos .NE. 0) THEN 
+         WRITE (UNIT = nulou,FMT = *)  
+     $ 'WARNING : Problem with model shared memory pool initialization'
+         WRITE (UNIT = nulou,FMT = *)
+     $        ' =======   Error code number = ',infos
+         CALL HALTE('STOP in inicmc')
+      ENDIF
+C
+C* CLIM/MPI2 or MPI1 initialization
+C
+#elif defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      ione = 1
+      IF (cchan .EQ. 'MPI1') cmpiarg(:)=' '
+      CALL CLIM_Init_Oasis(cjobnam, 'Oasis', 
+     $     ig_nmodel, cmodnam, nbcplproc, nbtotproc, cmpiarg,
+     $     iga_unitmod, nultr, infos)
+      IF (infos .NE. CLIM_Ok) THEN 
+         WRITE (UNIT = nulou,FMT = *) 
+     $        ' WARNING : Problem with MPI initialization '
+         WRITE (UNIT = nulou,FMT = *)
+     $        ' =======  CLIM error code number = ',infos
+         CALL HALTE('STOP in inicmc')
+      ENDIF
+      IF (.not. lg_oasis_field) THEN 
+         WRITE (UNIT = nulou,FMT = *) 
+     $        '===>>> All the fields are exchanged directly ' 
+         WRITE (UNIT = nulou,FMT = *) 
+     $        ' Oasis calls only his MPI initialization and 
+     $        sleeps until his MPI finalization'
+      ENDIF
+#else
+C     
+C* No message passing case
+C 
+      IF (cchan .EQ. 'NONE') THEN 
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou, FMT = *) 
+     $           ' NOTE : No message passing used in this run'
+            WRITE (UNIT = nulou,FMT = *)
+     $           ' ======= '
+         ENDIF
+      ELSE
+         CALL prcout('WARNING: your $CHANNEL option is wrong:',
+     $        cchan,1)
+         CALL HALTE('Wrong $CHANNEL option: STOP in inicmc')
+      ENDIF
+C      
+#endif
+C
+C* Put here stuff moved from inipar_alloc because grids.nc (and therefore
+C  grid dimensions) is not available yet.
+C*      If grids.nc file exists, get grid dimensions there.
+C
+        il_dimid(:)=0
+        il_auxbf=0
+        il_auxaf=0
+        allocate(cl_auxbf(ig_nfield))
+        cl_auxbf(:)=' '
+        allocate(cl_auxaf(ig_nfield))
+        cl_auxaf(:)=' '
+        ig_maxold_grid = 0
+        ig_maxnew_grid = 0
+C 
+        IF (lncdfgrd) CALL hdlerr
+     $      (NF_OPEN(cgrdnam//'.nc', NF_NOWRITE, nc_grdid), 'inicmc0')
+C       
+        DO 252 jf=1,ig_total_nfield
+          IF (ig_total_state(jf) .ne. ip_input) THEN
+              IF (lncdfgrd) THEN
+C
+C*                Initial dimensions
+                  clwork = cga_locatorbf(jf)
+                  icount = ilenstr(clwork,jpeight)
+                  clstrg = clwork(1:icount)//cglonsuf
+                  CALL hdlerr
+     $                (NF_INQ_VARID(nc_grdid, clstrg, il_varid), 
+     $                'inicmc1')
+                  CALL hdlerr
+     $                (NF_INQ_VARDIMID(nc_grdid,il_varid, il_dimid),
+     $                'inicmc2')
+                  CALL hdlerr
+     $                (NF_INQ_DIMLEN(nc_grdid, il_dimid(1), il_len),
+     $                'inicmc3')
+                  IF (lg_state(jf))
+     $                nlonbf(ig_number_field(jf)) = il_len
+                  CALL hdlerr
+     $                (NF_INQ_DIMLEN(nc_grdid, il_dimid(2), il_len),
+     $                'inicmc4')
+                  IF (lg_state(jf))
+     $                nlatbf(ig_number_field(jf)) = il_len
+C     
+C*                Final dimensions
+                  clwork = cga_locatoraf(jf)
+                  icount = ilenstr(clwork,jpeight)
+                  clstrg = clwork(1:icount)//cglonsuf
+                  CALL hdlerr
+     $                (NF_INQ_VARID(nc_grdid, clstrg, il_varid), 
+     $                'inicmc5')
+                  CALL hdlerr
+     $                (NF_INQ_VARDIMID(nc_grdid,il_varid, il_dimid),
+     $                'inicmc6')
+                  CALL hdlerr
+     $                (NF_INQ_DIMLEN(nc_grdid, il_dimid(1), il_len),
+     $                'inicmc7')
+                  IF (lg_state(jf))
+     $                nlonaf(ig_number_field(jf)) = il_len
+                  CALL hdlerr
+     $                (NF_INQ_DIMLEN(nc_grdid, il_dimid(2), il_len),
+     $                'inicmc8')
+                  IF (lg_state(jf))
+     $                nlataf(ig_number_field(jf)) = il_len
+C
+C
+               ENDIF
+           ENDIF
+C
+C* Get the number of different grids used 
+C
+           IF (lg_state(jf)) then
+              IF (ig_number_field(jf).eq.1) THEN
+                 cl_auxbf(1) = cficbf(1)
+                 cl_auxaf(1) = cficaf(1)
+                 ig_grid_nbrbf(1)=1
+                 ig_grid_nbraf(1)=1
+                 il_auxbf = 1
+                 il_auxaf = 1
+                 ig_maxold_grid = nlonbf(ig_number_field(jf)) * 
+     $                nlatbf(ig_number_field(jf))
+                 ig_maxnew_grid = nlonaf(ig_number_field(jf)) * 
+     $                nlataf(ig_number_field(jf))
+              ELSEIF (ig_number_field(jf).gt.1) THEN
+                 IF (ALL(cl_auxbf.ne.
+     $                cficbf(ig_number_field(jf)))) THEN
+                    il_auxbf=il_auxbf + 1
+                    cl_auxbf(il_auxbf)=cficbf(ig_number_field(jf))
+                    ig_grid_nbrbf(ig_number_field(jf))=il_auxbf
+                    ig_maxold_grid = ig_maxold_grid + 
+     $                   (nlonbf(ig_number_field(jf)) *
+     $                   nlatbf(ig_number_field(jf)))
+                 ELSE
+                    DO ib = 1, il_auxbf
+                       IF (cficbf(ig_number_field(jf)).eq.
+     $                      cl_auxbf(ib))
+     $                      ig_grid_nbrbf(ig_number_field(jf))= ib
+                    ENDDO
+                 ENDIF
+                 IF (ALL(cl_auxaf.ne.
+     $                cficaf(ig_number_field(jf)))) THEN
+                    il_auxaf=il_auxaf + 1
+                    cl_auxaf(il_auxaf)=cficaf(ig_number_field(jf))
+                    ig_grid_nbraf(ig_number_field(jf))=il_auxaf
+                    ig_maxnew_grid = ig_maxnew_grid + 
+     $                   (nlonaf(ig_number_field(jf)) *
+     $                   nlataf(ig_number_field(jf)))
+                 ELSE
+                    DO ib = 1, il_auxaf
+                       IF (cficaf(ig_number_field(jf)).eq.
+     $                      cl_auxaf(ib))
+     $                      ig_grid_nbraf(ig_number_field(jf))= ib
+                    ENDDO
+                 ENDIF  
+             ENDIF
+         ENDIF
+ 252   END DO
+C
+C*     Close netcdf file
+       IF (lncdfgrd) call hdlerr (NF_CLOSE(nc_grdid),'inicmc9')
+C 
+       IF (lg_oasis_field) THEN 
+          ALLOCATE (il_sizold(ig_nfield))
+          ALLOCATE (il_siznew(ig_nfield))
+          il_sizold(:) = 0
+          il_siznew(:) = 0
+          DO jf=1,ig_nfield
+            il_sizold (jf) = nlonbf(jf)*nlatbf(jf)
+            il_siznew (jf) = nlonaf(jf)*nlataf(jf)
+            ig_maxgrd = imaxim(il_sizold, ig_nfield)
+            IF (imaxim(il_siznew, ig_nfield).gt.ig_maxgrd)
+     $          ig_maxgrd = imaxim(il_siznew, ig_nfield)
+          ENDDO
+          WRITE(nulou,*)
+     $        'Maximum size of the different grids of indirect fields:',
+     $        ig_maxgrd
+          WRITE(nulou,*)' '
+C
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+          ig_CLIMmax = 3 + CLIM_Clength + 2*ig_total_nfield * 
+     $    (CLIM_Clength + 5 + CLIM_ParSize)
+          IF (ig_CLIMmax.lt.ig_maxgrd ) 
+     $        ig_CLIMmax = ig_maxgrd
+          ALLOCATE (pkwork(ig_CLIMmax), stat = il_ERR)
+          IF (il_ERR.NE.0) WRITE(nulou,*)
+     $        'Error in pkwork allocation in inicmc '
+          pkwork(:)=0 
+#endif        
+C     
+C*          Search sum of grids sizes of fields before and after interpolation
+C     
+          ig_maxold = isumi (il_sizold, ig_nfield)
+          ig_maxnew = isumi (il_siznew, ig_nfield)
+          WRITE(nulou,*)
+     $        'Sum of grid sizes of fields before interpolation : ',
+     $        ig_maxold
+          WRITE(nulou,*)' '
+          WRITE(nulou,*)
+     $        'Sum of grid sizes of fields after interpolation : ',
+     $        ig_maxnew
+          WRITE(nulou,*)' '
+C     
+C*          Search dimension of "nwork" array
+C     
+          ALLOCATE (il_maxaux(ig_nfield))
+          il_maxaux(:)=0
+          DO jf = 1,ig_nfield
+            il_redu = 0
+            IF (ntronca(jf) .NE. 0) THEN
+                IF (ntronca(jf) .EQ. 16) THEN
+                    il_redu = nredu16
+                ELSE IF (ntronca(jf) .EQ. 24)  THEN 
+                    il_redu = nredu24
+                ELSE IF (ntronca(jf) .EQ. 32)  THEN 
+                    il_redu = nredu32
+                ELSE IF (ntronca(jf) .EQ. 48)  THEN 
+                    il_redu = nredu48   
+                ELSE IF (ntronca(jf) .EQ. 80)  THEN 
+                    il_redu = nredu80
+                ELSE IF (ntronca(jf) .EQ. 160)  THEN 
+                    il_redu = nredu160
+                ELSE 
+                    CALL prtout
+     $                  ('WARNING!!! Oasis cannot treat this grid with 
+     $                  2*NO latitude lines with NO = ',
+     $                  ntronca(jf), 2)
+                ENDIF
+            ENDIF
+            IF (il_siznew(jf).ge.(il_redu+nlatbf(jf))) THEN
+                il_maxaux(jf) = il_siznew(jf)
+            ELSE
+                il_maxaux(jf) = il_redu+nlatbf(jf)
+            ENDIF
+          END DO
+          ig_nwork = imaxim (il_maxaux, ig_nfield)
+C     
+C*          Search dimension of "work" array
+C     
+          CALL izero(il_maxaux, ig_nfield)
+          DO jf = 1, ig_nfield
+            il_maxaux(jf) = nbnfld(jf)*il_siznew(jf)
+            IF (il_maxaux(jf).lt.(nbofld(jf)*il_sizold(jf)))
+     $          il_maxaux(jf) = nbofld(jf)*il_sizold(jf)
+            IF (il_maxaux(jf).lt.(nlonaf(jf)+nlataf(jf)
+     $          +2*il_sizold(jf)+2*il_siznew(jf))) 
+     $          il_maxaux(jf) = nlonaf(jf) + nlataf(jf)
+     $          +2*il_sizold(jf) + 2*il_siznew(jf)
+          END DO
+          ig_work = imaxim(il_maxaux, ig_nfield)
+          IF (ig_work.lt.(3*ig_maxgrd)) 
+     $        ig_work = 3*ig_maxgrd
+C     
+          DEALLOCATE (il_maxaux)
+          DEALLOCATE (il_sizold)
+          DEALLOCATE (il_siznew)
+      ENDIF
+      DEALLOCATE (cl_auxbf)
+      DEALLOCATE (cl_auxaf)
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      IF (lg_bsend) THEN
+          ii=0
+          rl_testvar = 0.0_ip_double_p
+          integer_byte_size = BIT_SIZE(ii)/8
+          INQUIRE (iolength=io_size) ii
+          integer_io_size = io_size
+          INQUIRE (iolength=io_size) rl_testvar
+          il_ibyt = io_size/integer_io_size*integer_byte_size
+          il_bufsendsize = 2*ig_clim_nfield*
+     $        (ig_maxgrd + MPI_BSEND_OVERHEAD/il_ibyt+1)
+          ALLOCATE (dg_bufsend(il_bufsendsize), stat = il_err)
+          IF (il_ERR.ne.0) WRITE(nulou,*)'Error in dg_bufsend
+     $        allocation in CLIM_Init_Oasis'
+          dg_bufsend(:)=0
+          il_bufsendsizebyt = il_bufsendsize * il_ibyt 
+C
+C*   Attach a buffer able to contain the maximum possible number of
+C    coupling fields with maximum possible
+C    size (ig_maxgrd) supposed to be declared as DOUBLE.  
+          CALL MPI_Buffer_Attach(dg_bufsend, il_bufsendsizebyt,mpi_err)
+          WRITE(nulou,*)'Attached buffer of size=', il_bufsendsizebyt
+      ENDIF
+#endif
+C
+C* END of stuff moved from inipar_alloc         
+C
+C* Define ports and start the communication only if one field (at least) 
+C  goes through Oasis
+C
+      IF (lg_oasis_field) THEN
+C     
+C*    2. Define ports or files for data exchange
+C     ---------------------------------------
+C     
+C     * PIPE case: define and open pipe files (FIFO)
+C     
+#ifdef use_comm_PIPE
+         infos = 0
+         DO 250 jf = 1, ig_nfield
+C     
+C     * Define pipes actual names for each field
+C     
+C     - Reading
+C     
+            clpinp = cnaminp(jf)
+C     - Writing
+            clpout = cnamout(jf)
+C     
+C     * Create pipes
+C     
+            CALL PIPE_Define (cnaminp(jf), cnamout(jf), 
+     $           clpinp, clpout , info(jf))
+            infos = infos + info(jf)
+ 250     CONTINUE
+         IF (infos .NE. 0) THEN 
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' WARNING : Problem with field pipe initialization'
+            WRITE (UNIT = nulou,FMT = *)
+     $           ' =======   Error code number = ',infos
+            CALL HALTE('STOP in inicmc')
+         ENDIF
+c         ENDIF
+C     
+C     * SIPC case
+C     
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+         infos = 0
+         DO 260 jf = 1, ig_nfield
+C     
+C     * Create two shared memory pools for each field
+C     
+            CALL SIPC_Define (jf, info(jf))  
+            infos = infos + info(jf)
+ 260     CONTINUE
+         IF (infos .NE. 0) THEN 
+            WRITE (UNIT = nulou,FMT = *) 
+     $           'WARNING : Problem with field shared memory pool 
+     $           initialization'
+            WRITE (UNIT = nulou,FMT = *)
+     $           ' =======   Error code number = ',infos
+            CALL HALTE('STOP in inicmc')
+         ELSE
+C     
+C     * If everything went alright, open one dummy file signaling  
+C     that pools for exchange are opened
+C     
+            OPEN (UNIT = nudum, FILE = 'DUMMY_SIPC', STATUS 
+     $           = 'NEW')
+            CLOSE (UNIT = nudum)
+            IF (nlogprt .GE. 1) THEN
+               WRITE (UNIT = nulou,FMT = *)
+     $              '* ===>>> : file DUMMY_SIPC created'
+               WRITE (UNIT = nulou,FMT = *) 
+     $              '  ------   -----------------------'
+            ENDIF
+        ENDIF
+C     
+C     * CLIM case: define ports
+C
+#elif defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE 
+C     
+C     * Input ports for incoming fields
+C
+         infos = CLIM_Ok
+         iparal(CLIM_Strategy) = CLIM_Serial
+         iparal(CLIM_Offset) = 0
+         DO 210 jf = 1, ig_nfield
+            iparal(CLIM_Length) = nlonbf(jf) * nlatbf(jf)
+            CALL CLIM_Define (ig_portin_id(jf),cnaminp(jf),CLIM_In, 
+     $           CLIM_Real,iparal, info(jf))
+            infos = infos + info(jf)
+ 210     CONTINUE
+         IF (infos .NE. CLIM_Ok) THEN
+            DO 220 jf = 1, ig_nfield
+               IF (info(jf) .NE. CLIM_Ok) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                 ' WARNING : Problem with port ', cnaminp(jf)
+                  WRITE (UNIT = nulou,FMT = *)
+     $                 ' =======   Error code number = ',info(jf)
+               ENDIF 
+ 220        CONTINUE 
+            CALL HALTE ('STOP in inicmc')
+         ENDIF 
+C     
+C     * Output ports for outgoing fields : serial decomposition
+C     
+         infos = CLIM_Ok
+         iparal(CLIM_Strategy) = CLIM_Serial
+         iparal(CLIM_Offset) = 0
+         DO 230 jf = 1, ig_nfield
+            iparal(CLIM_Length) = nlonaf(jf) * nlataf(jf)
+            CALL CLIM_Define (ig_portout_id(jf), cnamout(jf), 
+     $           CLIM_Out, CLIM_Real, iparal, info(jf))
+            infos = infos + info(jf)
+ 230     CONTINUE 
+         IF (infos .NE. CLIM_Ok) THEN
+            DO 240 jf = 1, ig_nfield
+               IF (info(jf) .NE. CLIM_Ok) THEN
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                 ' WARNING : Problem with port ', cnamout(jf)
+                  WRITE (UNIT = nulou,FMT = *)
+     $                 ' =======   Error code number = ',info(jf)
+               ENDIF 
+ 240        CONTINUE 
+            CALL HALTE ('STOP in inicmc')
+         ENDIF
+#endif
+C     
+C*    3. Start the communication and get timestep information
+C     ----------------------------------------------------
+#ifdef use_comm_PIPE
+         infos = 0
+         DO 320 jm = 1, ig_nmodel
+            CALL PIPE_Stepi (cmodnam(jm), jm, 
+     $           istep, ifcpl, idt, infos)
+            IF (infos .NE. 0) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' WARNING : Problem in getting step info 
+     $              from model ', cmodnam(jm)
+               WRITE (UNIT = nulou,FMT = *)
+     $              ' =======   Error code number = ',infos
+               CALL HALTE('STOP in inicmc')
+            ELSE
+               IF (nlogprt .GE. 1) THEN
+                  WRITE (UNIT = nulou,FMT = *)
+     $                 ' Got step information from model ', 
+     $                 cmodnam(jm)
+               ENDIF
+            ENDIF
+            mstep(jm) = istep
+            mfcpl(jm) = ifcpl
+            mdt(jm) = idt
+ 320     CONTINUE 
+C     
+C     * SIPC or GMEM Case
+C     
+#elif defined use_comm_SIPC || defined use_comm_GMEM
+         infos = 0
+         DO 330 jm = 1, ig_nmodel
+            CALL SIPC_Stepi (cmodnam(jm), jm, 
+     $           istep, ifcpl, idt, infos)
+            IF (infos .NE. 0) THEN
+               CALL prcout
+     $              ('WARNING: Problem in getting step info from 
+     $              model', cmodnam(jm), 1)
+               CALL prtout('Error code number = ',infos,1)
+               CALL HALTE('STOP in inicmc')
+            ELSE
+               CALL prcout
+     $              ('Got step information from model ',
+     $              cmodnam(jm), 1)
+            ENDIF
+            mstep(jm) = istep
+            mfcpl(jm) = ifcpl
+            mdt(jm) = idt
+ 330     CONTINUE 
+c
+C     * CLIM CASE
+C
+#elif defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+c 
+         CALL CLIM_Start (infos)
+         IF (infos .NE. CLIM_Ok) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' WARNING : Problem in starting CLIM '
+            WRITE (UNIT = nulou,FMT = *)
+     $           ' =======   Error code number = ',infos
+         ENDIF
+         DO 310 jm = 1, ig_nmodel
+            CALL CLIM_Stepi (cmodnam(jm), infos)
+            IF (infos .lt. nbcplproc(jm)) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              'PROBLEM: Got initial informations only from',
+     $              infos
+               WRITE (UNIT = nulou,FMT = *)
+     $              'processes of model',  cmodnam(jm) 
+               CALL halte ('STOP in inicmc.f')
+            ELSE
+               IF (nlogprt .GE. 1) THEN  
+                  WRITE (UNIT = nulou,FMT = *)
+     $                 ' Got step informations from model ', 
+     $                 cmodnam(jm)
+               ENDIF
+            ENDIF
+ 310     CONTINUE
+#endif
+      ENDIF
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (lg_oasis_field) DEALLOCATE(info)
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine inicmc ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inidya.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inidya.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inidya.f	(revision 1677)
@@ -0,0 +1,198 @@
+      SUBROUTINE inidya
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inidya*  - Initialize simulated dynamic allocation
+C
+C     Purpose:
+C     -------
+C     Set up pseudo-dynamic allocation of arrays.
+C     Define adresses and lengths of small arrays in big arrays
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inidya*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     ineed
+C
+C     Externals:
+C     ---------
+C     chkmem
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/08/23  created 
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_string
+      USE mod_memory
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) il_memtot(2)
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: 
+     $     nsizold_grid_aux, nsiznew_grid_aux, nadrold_grid_aux, 
+     $     nadrnew_grid_aux
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C* This routine will be called only if one field (at least) goes through Oasis
+C
+      IF (lg_oasis_field) THEN
+C     
+C*    1. Set up memory dynamic allocation
+C     --------------------------------
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           ROUTINE inidya  -  Level 0'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           **************     *******'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' Set up memory dynamic allocation'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+C
+C* Allocation of local arrays
+C
+         ALLOCATE (nsizold_grid_aux(maxval(ig_grid_nbrbf)))
+         nsizold_grid_aux(:)=0
+         ALLOCATE (nsiznew_grid_aux(maxval(ig_grid_nbraf)))
+         nsiznew_grid_aux(:)=0
+         ALLOCATE (nadrold_grid_aux(maxval(ig_grid_nbrbf)))
+         nadrold_grid_aux(:)=0
+         ALLOCATE (nadrnew_grid_aux(maxval(ig_grid_nbraf)))
+         nadrnew_grid_aux(:)=0
+C     
+C* Zero size and adress arrays
+C     
+         CALL izero (nsizold, ig_nfield)
+         CALL izero (nsiznew, ig_nfield)
+         CALL izero (nadrold, ig_nfield)
+         CALL izero (nadrnew, ig_nfield)
+         CALL izero (nadrold_grid, ig_nfield)
+         CALL izero (nadrnew_grid, ig_nfield)
+C     
+C* Zero main storage area
+C     
+C* - Integer arrays: masks
+C     
+         CALL izero (mskold, ig_maxold_grid)
+         CALL izero (msknew, ig_maxnew_grid)
+C     
+C* - Real arrays: fields, grids, surfaces
+C     
+         CALL szero (fldold, ig_maxold)
+         CALL szero (fldnew, ig_maxnew)
+         CALL szero (xgrold, ig_maxold_grid)
+         CALL szero (ygrold, ig_maxold_grid)
+         CALL szero (xgrnew, ig_maxnew_grid)
+         CALL szero (ygrnew, ig_maxnew_grid)
+         CALL szero (surold, ig_maxold_grid)
+         CALL szero (surnew, ig_maxnew_grid)
+
+C     
+C* Get the sizes for each small array
+C     
+         DO 110 jf = 1, ig_nfield
+            nsizold(jf) = nlonbf(jf) * nlatbf(jf)
+            nsiznew(jf) = nlonaf(jf) * nlataf(jf)
+            nsizold_grid_aux (ig_grid_nbrbf(jf)) = 
+     $           nlonbf(jf) * nlatbf(jf)
+            nsiznew_grid_aux (ig_grid_nbraf(jf)) = 
+     $           nlonaf(jf) * nlataf(jf)
+ 110     CONTINUE
+C     
+C* Get the pointers for each small array
+C     
+         nadrold(1) = 1
+         nadrnew(1) = 1
+         nadrold_grid_aux(1) = 1
+         nadrnew_grid_aux(1) = 1
+         nadrold_grid(1) = 1
+         nadrnew_grid(1) = 1
+         
+         DO ib = 2, maxval(ig_grid_nbrbf)
+            nadrold_grid_aux(ib) = nadrold_grid_aux(ib-1) + 
+     $           nsizold_grid_aux(ib-1)
+         ENDDO
+         DO ib = 2, maxval(ig_grid_nbraf)
+            nadrnew_grid_aux(ib) = nadrnew_grid_aux(ib-1) + 
+     $           nsiznew_grid_aux(ib-1)
+         ENDDO
+
+         DO 120 jf = 2, ig_nfield
+            nadrold(jf) = nadrold(jf-1) + nsizold(jf-1)
+            nadrnew(jf) = nadrnew(jf-1) + nsiznew(jf-1)
+            nadrold_grid(jf) = nadrold_grid_aux(ig_grid_nbrbf(jf))
+            nadrnew_grid(jf) = nadrnew_grid_aux(ig_grid_nbraf(jf))
+ 120     CONTINUE
+C     
+C* Print memory required for field and grid arrays
+C
+         il_memtot(1) = ((ig_maxold + 3*ig_maxold_grid)*ip_realwp_p
+     $   + ig_maxold_grid*ip_intwp_p)/1000
+         il_memtot(2) = ((ig_maxnew + 3*ig_maxnew_grid)*ip_realwp_p
+     $   + ig_maxnew_grid*ip_intwp_p)/1000
+C
+         IF (nlogprt .GE. 1) THEN
+             WRITE (UNIT = nulou,FMT = 1001) il_memtot(1), il_memtot(2)
+         ENDIF
+ 1001    FORMAT(1H ,5X,
+     $   'Memory (kB) requested for source field and grid arrays',
+     $    I10,/, 1H ,5X,
+     $   'Memory (kB) requested for target field and grid arrays', I10)
+C     
+C*    2. End of routine
+C     --------------
+C     
+         DEALLOCATE (nsizold_grid_aux)
+         DEALLOCATE (nsiznew_grid_aux)
+         DEALLOCATE (nadrold_grid_aux)
+         DEALLOCATE (nadrnew_grid_aux)
+C
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '          --------- End of routine inidya ---------'
+            CALL FLUSH (nulou)
+         ENDIF
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inigrd.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inigrd.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inigrd.f	(revision 1677)
@@ -0,0 +1,486 @@
+      SUBROUTINE inigrd
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inigrd*  - Initialize gcm's grids
+C
+C     Purpose:
+C     -------
+C     Get atmospheric and oceanic grids and masks as well as scale factors
+C     for interpolation purposes.
+C
+C     ***NOTE***
+C     ----------
+C     Grids, masks and scale factors must be ordered with the OASIS convention.
+C     They go from South to North and from Greenwhich to the east.
+C     EXCEPTION: array maskr (mask for reduced gaussian grid) must
+C     be ordered as in the atmospheric code (North to South in 
+C     Arpege case).
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inigrd*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     locread, locrint
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/08/31  modified : new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      01/03/23  added: netCDF auxilary files
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_memory
+      USE mod_string
+      USE mod_unitncdf
+      USE mod_analysis
+      USE mod_label
+      USE mod_unit
+      USE mod_printing
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clwork
+      CHARACTER*8 clstrg,clstrg1,clstrg2,clstrg3,clstrg4
+      CHARACTER*8 clstrg5,clstrg6
+      INTEGER (kind=ip_intwp_p) il_varid
+      INTEGER (kind=ip_intwp_p) ist(2), icnt(2)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C* This routine will be called only if one field (at least) goes through Oasis
+C
+      IF (ig_nfield .ne.0) THEN
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE inigrd  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' get gcms grids, masks and surfaces'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      ist(:)=0
+      icnt(:)=0
+C
+C* Initializa error codes
+C
+      infos = 0
+      iflag = 0
+C
+C
+C*    2. Get gcm's grids, masks and mesh surfaces
+C        ----------------------------------------
+C
+!$omp parallel do default (shared)
+!$omp+ private (jf,iadrold,isizold,iadrnew,isiznew)
+!$omp+ private (clwork,icount,clstrg,clstrg1)
+!$omp+ private (clstrg2,clstrg3,clstrg4,clstrg5)
+!$omp+ private (clstrg6)
+!$omp+ private (istatus,iunit1,inunit2,iunit3)
+!$omp+ private (iunit4,iunit5,iunit6,iunit7)
+!$omp+ private (iflag,ist,icnt,nc_file,n_intty)
+!$omp+ private (n_reaty,il_varid)
+!$omp+ reduction (+:infos)
+
+      DO 200 jf = 1, ig_nfield
+C
+C* Print
+C
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Start reading source grid data for field nbr=',jf,2)
+        ENDIF
+C
+C* Assign local variables to array sizes and pointers
+C
+        iadrold = nadrold_grid(jf)
+        isizold = nsizold(jf)
+        iadrnew = nadrnew_grid(jf)
+        isiznew = nsiznew(jf)
+C
+C* Get the right locator string for initial grids files
+C
+        clwork = cficbf(jf)
+        icount = ilenstr(clwork,jpeight)
+        clstrg1 = clwork(1:icount)//cglonsuf
+C
+C* Read longitudes of initial grid associated to field jf
+C
+        iunit1 = nulgr
+        IF (lncdfgrd) THEN
+C Next BLOCK done only once per field
+            ist(1)=1 ; ist(2)=1
+            icnt(1)=nlonbf(jf) ; icnt(2)=nlatbf(jf)
+C
+            nc_file = nc_grdid
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_file, clstrg1, il_varid), 'inigrd')
+            CALL hdlerr
+     $          (NF_INQ_VARTYPE(nc_file, il_varid, n_reaty), 'inigrd')
+            IF (n_reaty .eq. NF_FLOAT) THEN
+                 IF ( ip_realwp_p .ne. ip_single_p ) THEN
+                    WRITE (nulou, *)
+     $             'Incoherence: Oasis is compiled in double precision'
+                    WRITE (nulou, *)
+     $   'but Grid auxiliary file contains single precision REAL'
+                    CALL HALTE('STOP in getfld')
+                 ENDIF
+               CALL hdlerr(NF_GET_VARA_REAL
+     $              (nc_file, il_varid, ist, icnt, 
+     $               xgrold(iadrold:iadrold+isizold-1)),'inigrd')
+            ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                 IF ( ip_realwp_p .ne. ip_double_p ) THEN
+                    WRITE (nulou, *)
+     $             'Incoherence: Oasis is compiled in single precision'
+                    WRITE (nulou, *)
+     $   'but Grid auxiliary file contains double precision REAL'
+                    CALL HALTE('STOP in getfld')
+                 ENDIF               
+               CALL hdlerr(NF_GET_VARA_DOUBLE 
+     $              (nc_file, il_varid, ist, icnt, 
+     $               xgrold(iadrold:iadrold+isizold-1)),'inigrd')
+            ELSE
+                CALL prcout ('Problem with type of array =',clstrg1,1) 
+                CALL HALTE('STOP in inigrd')
+            ENDIF
+        ELSE
+            CALL locread (clstrg1,xgrold(iadrold),isizold,iunit1,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',iunit1,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg1,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout('Read source grid longitudes for field #',jf,1)
+        ENDIF
+C
+C* Read latitudes of initial grid associated to field jf
+C
+        clstrg2 = clwork(1:icount)//cglatsuf
+        IF (lncdfgrd) THEN
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_file, clstrg2, il_varid), 'inigrd')
+            IF (n_reaty .eq. NF_FLOAT) THEN
+                CALL hdlerr(NF_GET_VARA_REAL 
+     $              (nc_file, il_varid, ist, icnt, 
+     $              ygrold(iadrold:iadrold+isizold-1)), 'inigrd')
+            ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                CALL hdlerr(NF_GET_VARA_DOUBLE 
+     $              (nc_file, il_varid, ist, icnt, 
+     $              ygrold(iadrold:iadrold+isizold-1)), 'inigrd')
+            ENDIF
+        ELSE
+            CALL locread(clstrg2,ygrold(iadrold),isizold,iunit1,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',iunit1,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg2,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout('Read source grid latitudes for field # ',jf,1)
+        ENDIF
+C
+C* Read initial mask associated to field jf
+C
+        clstrg3 = clwork(1:icount)//cmsksuf
+        iunit2 = nulma
+        IF (lncdfgrd) THEN
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_mskid, clstrg3, il_varid), 'inigrd')
+            CALL hdlerr
+     $          (NF_INQ_VARTYPE(nc_mskid, il_varid, n_intty), 'inigrd')
+            IF (n_intty .eq. NF_INT) THEN
+                CALL hdlerr(NF_GET_VARA_INT 
+     $              (nc_mskid, il_varid, ist, icnt, 
+     $              mskold(iadrold:iadrold+isizold-1)), 'inigrd')
+            ELSE
+                CALL prcout ('Problem with type of array =',clstrg3,1) 
+                CALL HALTE('STOP in inigrd')
+            ENDIF
+        ELSE
+            CALL locrint (clstrg3,mskold(iadrold),isizold,iunit2,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',iunit2,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg3,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read source grid mask for field number =',jf,1)
+        ENDIF
+C
+C* Read initial mesh surface associated to field jf
+C
+        clstrg4 = clwork(1:icount)//csursuf
+        iunit3 = nulsu
+        IF (lncdfgrd) THEN
+            istatus = 
+     $          NF_INQ_VARID(nc_surid, clstrg4, il_varid)
+            IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                CALL prtout('Cannot read surface information for fld '
+     $              , jf, 1)
+                CALL HALTE ('STOP in inigrd')
+            ELSE IF (istatus .eq. NF_NOERR) THEN
+                IF (n_reaty .eq. NF_FLOAT) THEN
+                    istatus = NF_GET_VARA_REAL(nc_surid, 
+     $                   il_varid, ist, icnt, 
+     $                  surold(iadrold:iadrold+isizold-1))
+                    IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                        CALL prtout('Cannot read source grid surface 
+     $ information for field ' , jf, 1)
+                        CALL HALTE ('STOP in inigrd')
+                    ENDIF
+                ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                    istatus = NF_GET_VARA_DOUBLE(nc_surid, 
+     $                   il_varid, ist, icnt, 
+     $                  surold(iadrold:iadrold+isizold-1))
+                    IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                        CALL prtout('Cannot read source grid surface 
+     $ information for field ' , jf, 1)
+                        CALL HALTE ('STOP in inigrd')
+                    ENDIF
+                ENDIF
+            ENDIF
+        ELSE
+            CALL locread (clstrg4, surold(iadrold), isizold,
+     $          iunit3,iflag)
+            IF (iflag .NE. 0 .and. lsurf(jf)) THEN
+                CALL prtout('Problem in reading unit =',iunit3,2)
+                CALL prcout('Problem with array linked to string ',
+     $              clstrg4,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read source grid surface for field number ',jf,1)
+        ENDIF
+C
+C* Get the right locator string for final grids files
+C
+!$omp critical
+        clwork = cficaf(jf)
+        icount = ilenstr(clwork,jpeight)
+        clstrg5 = clwork(1:icount)//cglonsuf
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Start reading target grid data for field nbr =',jf,2)
+        ENDIF
+C
+C* Read longitudes of final grid associated to field jf
+C
+        iunit4 = nulgr
+        IF (lncdfgrd) THEN
+C Next BLOCK done only once per field
+            ist(1)=1 ; ist(2)=1
+            icnt(1)=nlonaf(jf) ; icnt(2)=nlataf(jf)
+C
+            nc_file = nc_grdid
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_file, clstrg5, il_varid), 'inigrd')
+            IF (n_reaty .eq. NF_FLOAT) THEN
+                CALL hdlerr(NF_GET_VARA_REAL
+     $              (nc_file, il_varid, ist, icnt, 
+     $              xgrnew(iadrnew:iadrnew+isiznew-1)), 'inigrd')
+            ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                CALL hdlerr(NF_GET_VARA_DOUBLE 
+     $              (nc_file, il_varid, ist, icnt, 
+     $              xgrnew(iadrnew:iadrnew+isiznew-1)), 'inigrd')
+            ENDIF
+        ELSE
+            CALL locread (clstrg5,xgrnew(iadrnew),isiznew,iunit4,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',iunit4,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg5,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+!$omp end critical
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read target grid longitudes for field number =',jf,1)
+        ENDIF
+C
+C* Read latitudes of final grid associated to field jf
+C
+!$omp critical
+        clstrg6 = clwork(1:icount)//cglatsuf
+        iunit5 = nulgr
+        IF (lncdfgrd) THEN
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_file, clstrg6, il_varid), 'inigrd')
+            IF (n_reaty .eq. NF_FLOAT) THEN
+                CALL hdlerr(NF_GET_VARA_REAL 
+     $              (nc_file, il_varid, ist, icnt, 
+     $              ygrnew(iadrnew:iadrnew+isiznew-1)), 'inigrd')
+            ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                CALL hdlerr(NF_GET_VARA_DOUBLE 
+     $              (nc_file, il_varid, ist, icnt, 
+     $              ygrnew(iadrnew:iadrnew+isiznew-1)), 'inigrd')
+            ENDIF
+        ELSE
+            CALL locread (clstrg6,ygrnew(iadrnew),isiznew,iunit5,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',nulgr,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg6,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+!$omp end critical
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read target grid latitudes for field number =',jf,1)
+        ENDIF
+C
+C* Read final mask associated to field jf
+C
+!$omp critical
+        clstrg = clwork(1:icount)//cmsksuf
+        iunit6 = nulma
+        IF (lncdfgrd) THEN
+            CALL hdlerr
+     $          (NF_INQ_VARID(nc_mskid, clstrg, il_varid), 'inigrd')
+            IF (n_intty .eq. NF_INT) THEN
+                CALL hdlerr(NF_GET_VARA_INT 
+     $              (nc_mskid, il_varid, ist, icnt, 
+     $              msknew(iadrnew:iadrnew+isiznew-1)), 'inigrd')
+            ENDIF
+        ELSE
+            CALL locrint (clstrg,msknew(iadrnew),isiznew,iunit6,iflag)
+            IF (iflag .NE. 0) THEN
+                CALL prtout('Problem in reading unit =',iunit6,2)
+                CALL prcout
+     $          ('Problem with array linked to string =',clstrg,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read target grid mask for field number =',jf,1)
+        ENDIF
+C
+!$omp end critical
+C* Read final mesh surface associated to field jf
+C
+!$omp critical
+        clstrg = clwork(1:icount)//csursuf
+        iunit7 = nulsu
+        IF (lncdfgrd) THEN
+            istatus = 
+     $          NF_INQ_VARID(nc_surid, clstrg, il_varid)
+            IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                CALL prtout('Cannot read surface information for fld '
+     $              , jf, 1)
+                CALL HALTE ('STOP in inigrd')
+            ELSE IF (istatus .eq. NF_NOERR) THEN
+                IF (n_reaty .eq. NF_FLOAT) THEN
+                    istatus = NF_GET_VARA_REAL(nc_surid, 
+     $              il_varid, ist, icnt, 
+     $                  surnew(iadrnew:iadrnew+isiznew-1))
+                    IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                        CALL prtout('Cannot read target grid surface 
+     $ information for field ' , jf, 1)
+                        CALL HALTE ('STOP in inigrd')
+                    ENDIF
+                ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
+                    istatus = NF_GET_VARA_DOUBLE(nc_surid, 
+     $               il_varid, ist, icnt, 
+     $                  surnew(iadrnew:iadrnew+isiznew-1))
+                    IF (istatus .ne. NF_NOERR .and. lsurf(jf)) THEN
+                        CALL prtout('Cannot read source grid surface 
+     $ information for field ' , jf, 1)
+                        CALL HALTE ('STOP in inigrd')
+                    ENDIF
+                ENDIF
+            ENDIF
+        ELSE
+            CALL locread (clstrg, surnew(iadrnew), isiznew,
+     $          iunit7,iflag)
+            IF (iflag .NE. 0 .and. lsurf(jf)) THEN
+                CALL prtout('Problem in reading unit =',iunit7,2)
+                CALL prcout('Problem with array linked to string ',
+     $              clstrg,1)
+                infos = infos + iflag
+            ENDIF
+        ENDIF
+!$omp end critical
+        IF (nlogprt .GE. 2) THEN
+            CALL prtout
+     $          ('Read target grid surface for field number ',jf,1)
+        ENDIF
+ 200  CONTINUE
+      IF (lncdfgrd) THEN
+          CALL hdlerr(NF_CLOSE(nc_grdid), 'inigrd')
+          CALL hdlerr(NF_CLOSE(nc_mskid), 'inigrd')
+          CALL hdlerr(NF_CLOSE(nc_surid), 'inigrd')
+      ENDIF
+C
+C* Finish up if problem in reading
+C
+      IF (infos .NE. 0) CALL HALTE('STOP in inigrd')
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine inigrd ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/iniiof.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/iniiof.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/iniiof.F	(revision 1677)
@@ -0,0 +1,522 @@
+      SUBROUTINE iniiof
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *iniiof*  - Open files
+C
+C     Purpose:
+C     -------
+C     Open files for grid related parameters, data transfer and 
+C     auxilary outputs
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *iniiof*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0beta   L. Terray      95/08/23  modified: new structure
+C       2.0       L. Terray      96/02/01  modified: no opening of
+C                                          CLIM trace file within oasis
+C       2.1       L. Terray      96/08/26  modified: open data file for
+C                                          SUBGRID Analysis
+C       2.3       S. Valcke      99/03/30  modified: open data file for
+C                                          NINENN analysis
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      01/03/23  removed: nulrd opening
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_parameter
+      USE mod_unitncdf
+      USE mod_string
+      USE mod_anais
+      USE mod_extrapol
+      USE mod_analysis
+      USE mod_unit
+      USE mod_hardware
+      USE mod_label
+      USE mod_printing
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clfic
+      LOGICAL ll_areas
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C* This routine will be called only if one field (at least) goes through Oasis
+C
+      IF (lg_oasis_field) THEN
+C     
+C*    1. Open files
+C        ----------
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           ROUTINE iniiof  -  Level 0'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           **************     *******'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' opening grid related files'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            iost = 0
+            WRITE (UNIT = nulou,FMT = *) ' opening gcms grid file '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         IF (.not. lncdfgrd) THEN
+            OPEN (UNIT = nulgr,FILE = cgrdnam,STATUS='OLD',
+     $           FORM ='UNFORMATTED',ERR = 110,IOSTAT = iost)
+            IF (nlogprt .GE. 1) THEN
+               WRITE (UNIT = nulou,FMT = 1001) nulgr, cgrdnam
+               WRITE (UNIT = nulou,FMT = *) ' '
+            ENDIF
+ 110        CONTINUE
+c           Try whether a new netcdf grids file was created at runtime
+            IF (iost .NE. 0) THEN
+               lncdfgrd = .true.
+            ENDIF
+         ENDIF
+         IF (lncdfgrd) THEN 
+            istatus=NF_OPEN(cgrdnam//'.nc', NF_NOWRITE, nc_grdid)
+            IF (istatus .ne. NF_NOERR) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>>> NO grids neither grids.nc files.'
+               CALL halte('STOP in iniiof')
+            ENDIF
+         ENDIF
+C     
+C* Masks file
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) '   opening gcm masks file '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         IF (lncdfgrd) THEN
+            istatus=NF_OPEN(cmsknam//'.nc', NF_NOWRITE, nc_mskid)
+            IF (istatus .ne. NF_NOERR) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>>> : error in opening masks.nc. We STOP!'
+               WRITE (UNIT = nulou,FMT = *) ' '
+               CALL HALTE('STOP in iniiof')   
+            ENDIF
+         ELSE
+            OPEN (UNIT = nulma,FILE = cmsknam,STATUS='OLD',
+     $           FORM ='UNFORMATTED',ERR = 120,IOSTAT = iost)
+            IF (nlogprt .GE. 1) THEN
+               WRITE (UNIT = nulou,FMT = 1001) nulma, cmsknam
+               WRITE (UNIT = nulou,FMT = *) ' '
+            ENDIF
+ 120        CONTINUE
+            IF (iost .ne. 0) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>>> : error opening masks file'
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' =======   =====               ===='
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' logical unit ',nulma,' error number = ',
+     $              iost
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' We STOP. Verify the file ', cmsknam
+               WRITE (UNIT = nulou,FMT = *) ' '
+               CALL HALTE('STOP in iniiof')   
+            ENDIF
+         ENDIF
+C     
+C* Surfaces file
+C     
+         DO 125 jf = 1, ig_nfield
+            IF (lsurf(jf)) ll_areas = .TRUE.
+ 125     CONTINUE
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) 'Trying open gcm surface file'
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         IF (lncdfgrd) THEN
+            istatus=NF_OPEN(csurnam//'.nc', NF_NOWRITE, nc_surid)
+            IF (istatus .ne. NF_NOERR .and. ll_areas) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>>> : error in opening areas.nc. We STOP!'
+               WRITE (UNIT = nulou,FMT = *) ' '
+               CALL HALTE('STOP in iniiof')   
+            ENDIF
+         ELSE
+            OPEN (UNIT = nulsu,FILE = csurnam,
+     $           FORM ='UNFORMATTED',ERR = 130,IOSTAT = iost)
+            IF (nlogprt .GE. 1) THEN
+               WRITE (UNIT = nulou,FMT = 1001) nulsu, csurnam
+               WRITE (UNIT = nulou,FMT = *) ' '
+            ENDIF
+ 130        CONTINUE
+            IF (iost .ne. 0 .and. ll_areas) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>>> : error opening surfaces file'
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' =======   =====                  ===='
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' logical unit ',nulsu,' error number = ', iost
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' We STOP. Verify the file ', csurnam
+               WRITE (UNIT = nulou,FMT = *) ' '
+               CALL HALTE ('STOP in iniiof')   
+            ENDIF
+         ENDIF
+C     
+C* Trace file for CLIM 
+C     
+         IF (nlogprt .GE. 1) THEN
+            IF (cchan .EQ. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              '      The CLIM trace file is opened'
+               WRITE (UNIT = nulou,FMT = *) 
+     $              '      within the CLIM program '
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' The name of the file is oasis.prt '
+               WRITE (UNIT = nulou,FMT = *) 
+     $              ' linked to logical unit = ', nultr
+            ENDIF
+         ENDIF
+C     
+C* Formats
+C     
+ 1001    FORMAT(10X,' open unit = ',I3,'    file ',A8,' ok')
+C     
+C     
+C*    2. Deal with restart/transfer files
+C     --------------------------------
+C     
+C* Files for input fields
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' opening restart/transfer files '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+
+         lncdfrst = .true.
+         DO jf = 1, ig_nfield
+            isamefic=0
+            DO 215 jj = 1, jf-1
+               IF (nluinp(jf) .eq. nluinp(jj)) THEN
+                  isamefic=isamefic+1
+                  nc_inpid(jf)=nc_inpid(jj)
+               ENDIF
+ 215        END DO
+            IF (isamefic .lt. 1) THEN
+               iunit = nluinp(jf)
+               clfic = cficinp(jf)
+c  Find the index of jf in total number of field
+               DO jj = 1, ig_total_nfield
+	          if ( jf .eq. ig_number_field(jj)) ig_ind = jj
+               END DO
+               IF (ig_lag(ig_ind) .gt. 0) THEN
+                  IF (lncdfrst) THEN
+                     istatus=NF_OPEN(clfic, NF_NOWRITE, nc_inpid(jf))
+                     IF (istatus .ne. NF_NOERR) THEN
+                        OPEN (UNIT = iunit,FILE = clfic,STATUS='OLD',
+     $                       FORM = 'UNFORMATTED',IOSTAT = iost)
+                        IF (iost .ne. 0) THEN
+                           CALL prtout
+     $                          ('No restart input file for field ',
+     $                          jf, 1)
+                           CALL HALTE('STOP in iniiof')
+                        ELSE
+                           IF (nlogprt .GE. 1) THEN
+                              WRITE (UNIT = nulou,FMT = 1001)iunit,clfic 
+                           ENDIF
+                           lncdfrst = .false.
+                        ENDIF
+                     ELSE
+                        IF (nlogprt .GE. 1) THEN
+                           WRITE (UNIT = nulou,FMT = *)
+     $                          '   opened netcdf restart file ', clfic
+                        ENDIF
+                     ENDIF
+                  ELSE
+                     OPEN (UNIT = iunit,FILE = clfic,STATUS='OLD',
+     $                    FORM = 'UNFORMATTED',IOSTAT = iost)
+                     IF (iost .ne. 0) THEN
+                        CALL prtout
+     $                       ('No binary restart input file for field ',
+     $                       jf, 1)
+                        CALL HALTE('STOP in iniiof')
+                     ELSE
+                        IF (nlogprt .GE. 1) THEN
+                           WRITE (UNIT = nulou,FMT = 1001) iunit, clfic
+                        ENDIF
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ENDIF
+         ENDDO
+cvg<<<
+
+C     
+C     
+C     *    3. Anais weights and output files and NINENN weight file
+C     -----------------------------------------------------
+C     
+C     * Weights file for ANAISM
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' open interpolation related files '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '      need file with surface mesh weights'
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         OPEN (UNIT = nulcc,FILE = cwanaism,
+     $        FORM ='UNFORMATTED',ERR = 310,IOSTAT = iost)
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = 1001) nulcc, cwanaism
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+ 310     CONTINUE
+         IF (iost .ne. 0) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>>> : error opening surfmesh weights file'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' =======   =====                          ===='
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' logical unit ',nulcc,' error number = ',
+     $           iost
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP. Verify the file', cwanaism
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE ('STOP in iniiof')   
+         ENDIF
+C     * Weights file for ANAISG
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '      need file with curvilinear grid weights'
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         OPEN (UNIT = nulgg,FILE = cwanaisg,
+     $        FORM ='UNFORMATTED',ERR = 320,IOSTAT = iost)
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = 1001) nulgg, cwanaisg
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+ 320     CONTINUE 
+         IF (iost .ne. 0) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>>> : error opening curvilinear weights file'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' =======   =====                             ===='
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' logical unit ',nulgg,' error number = ',
+     $           iost
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP. Verify the file', cwanaisg
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE ('STOP in iniiof')   
+         ENDIF
+C     * ANAIS output FILE
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) '      open ANAIS output file'
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         OPEN (UNIT = nulan,FILE = cnaisout, STATUS='NEW',
+     $        FORM ='FORMATTED',ERR = 330,IOSTAT = iost)
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = 1001) nulan, cnaisout
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+ 330     CONTINUE
+         IF (iost .ne. 0) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>>> : error opening ANAIS output file'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' =======   =====                      ===='
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' logical unit ',nulan,' error number = ',
+     $           iost
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP. Verify the file', cnaisout
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE ('STOP in iniiof')   
+         ENDIF
+C     
+C     * Weights file for NINENN
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           'need file with weights, address and iteration number'
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+#if !defined key_openmp
+         OPEN (UNIT = nulgn,FILE = cwninenn,
+     $        FORM ='UNFORMATTED',ERR = 340,IOSTAT = iost)
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = 1001) nulgn, cwninenn
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+ 340     CONTINUE 
+         IF (iost .ne. 0) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' ===>>>> : error opening weight file'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' =======   =====                ===='
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' logical unit ',nulgn,' error number = ',
+     $           iost
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' We STOP. Verify the file', cwninenn
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE ('STOP in iniiof')   
+         ENDIF
+#endif
+C
+C*    4. Deal with data files used in analysis routines
+C        ----------------------------------------------
+C
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' open analysis related files '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+         DO 410 jf = 1, ig_nfield
+            DO 420 ja = 1, ig_ntrans(jf)
+               IF(canal(ja,jf) .EQ. 'CORRECT') THEN
+                  DO 430 jc = 1, ncofld(jf)
+                     iunit = nludat(jc,jf)
+                     clfic = ccofic(jc,jf)
+                     OPEN(UNIT = iunit,FILE = clfic,
+     $                    FORM ='UNFORMATTED',ERR = 440,IOSTAT = iost)
+                     IF (nlogprt .GE. 1) THEN
+                        WRITE (UNIT = nulou,FMT = 1001) iunit, clfic
+                        WRITE (UNIT = nulou,FMT = *) ' '
+                     ENDIF
+ 440                 IF (iost .ne. 0) THEN
+                        WRITE (UNIT = nulou,FMT = *) 
+     $                       ' ===>>>> : error opening data file'
+                        WRITE (UNIT = nulou,FMT = *) 
+     $                       ' =======   =====              ===='
+                        WRITE (UNIT = nulou,FMT = *) 
+     $                       ' logical unit ',iunit,' error number = ',
+     $                       iost
+                        WRITE (UNIT = nulou,FMT = *) 
+     $                       ' We STOP. Verify the file ', clfic
+                        WRITE (UNIT = nulou,FMT = *) ' '
+                        CALL HALTE('STOP in iniiof')
+                     ENDIF
+ 430              CONTINUE 
+               ELSE IF(canal(ja,jf) .EQ. 'MOZAIC') THEN
+                  iunit = nlumap(jf)
+                  clfic = cgrdmap(jf)
+                  OPEN(UNIT = iunit,FILE = clfic, 
+     $                 FORM ='UNFORMATTED',ERR = 450,IOSTAT = iost)
+                  IF (nlogprt .GE. 1) THEN
+                     WRITE (UNIT = nulou,FMT = 1001) iunit, clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                  ENDIF
+ 450              IF (iost .ne. 0) THEN
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' ===>>>> : error opening mapping file'
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' =======   =====                 ===='
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' logical unit ',iunit,' error number = ',
+     $                    iost
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' We STOP. Verify the file ', clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                     CALL HALTE('STOP in iniiof')
+                  ENDIF
+               ELSE IF(canal(ja,jf) .EQ. 'FILLING') THEN
+                  iunit = nlufil(jf)
+                  clfic = cfilfic(jf)
+                  OPEN(UNIT = iunit,FILE = clfic,
+     $                 FORM ='UNFORMATTED',ERR = 460,IOSTAT = iost)
+                  IF (nlogprt .GE. 1) THEN
+                     WRITE (UNIT = nulou,FMT = 1001) iunit, clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                  ENDIF
+ 460              IF (iost .ne. 0) THEN
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' ===>>>> : error opening filling data file'
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' =======   =====         ======= ===='
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' logical unit ',iunit,' error number = ',
+     $                    iost
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' We STOP. Verify the file ', clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                     CALL HALTE('STOP in iniiof')
+                  ENDIF
+               ELSE IF(canal(ja,jf) .EQ. 'SUBGRID') THEN
+                  iunit = nlusub(jf)
+                  clfic = cgrdsub(jf)
+                  OPEN(UNIT = iunit,FILE = clfic,
+     $                 FORM ='UNFORMATTED',ERR = 470,IOSTAT = iost)
+                  IF (nlogprt .GE. 1) THEN
+                     WRITE (UNIT = nulou,FMT = 1001) iunit, clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                  ENDIF
+ 470              IF (iost .ne. 0) THEN
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' ===>>>> : error opening subgrid data file'
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' =======   =====         ======= ===='
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' logical unit ',iunit,' error number = ',
+     $                    iost
+                     WRITE (UNIT = nulou,FMT = *) 
+     $                    ' We STOP. Verify the file ', clfic
+                     WRITE (UNIT = nulou,FMT = *) ' '
+                     CALL HALTE('STOP in iniiof')
+                  ENDIF
+               ENDIF
+ 420        CONTINUE 
+ 410     CONTINUE 
+C
+C
+C*    5. End of routine
+C        --------------
+C
+         IF (nlogprt .GE. 1) THEN
+            WRITE(UNIT = nulou,FMT = *) ' '
+            WRITE(UNIT = nulou,FMT = *) 
+     $           '          ---------- End of routine iniiof ---------'
+            CALL FLUSH (nulou)
+         ENDIF
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inilun.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inilun.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inilun.f	(revision 1677)
@@ -0,0 +1,174 @@
+      SUBROUTINE inilun
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inilun*  - Initialize logical unit numbers
+C
+C     Purpose:
+C     -------
+C     Creates and prints logical unit numbers used to deal with
+C     grids, masks and surfaces files as well as anais-related files
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inilun*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/08/23  modified: new structure
+C       2.2       L. Terray      97/10/10  added: unit nudum for SVIPC
+C       2.3       S. Valcke      99/03/30  added: unit nulgn for NINENN
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_parameter
+      USE mod_string
+      USE mod_unit
+      USE mod_printing
+      USE mod_hardware
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Assign unit numbers and initialize comlun
+C        -----------------------------------------
+C
+C* First we open output file for coupler
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE inilun  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Set up logical unit numbers'
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* If there is no field going through Oasis then assign only the trace file 
+C  unit for CLIM
+      IF (.not. lg_oasis_field) THEN
+         nultr = 7
+         IF (nlogprt .GE. 1)
+     $        WRITE (UNIT = nulou,FMT = *)'Trace file unit for CLIM :',
+     $        nultr
+      ELSE
+C* Grids file
+         nulgr = 11
+C* Masks file
+         nulma = 12
+C* Surfaces file
+         nulsu = 13
+C* File for reduced grid masks
+         nulrd = 14
+C* Trace file for CLIM and PVM
+         nultr = 7
+C* Output file for ANAIS interpolation
+         nulan = 8
+C* Dummy file for SVIPC library
+         nudum = 9
+C* Anaism weights file
+         nulcc = 16
+C* Anaisg weights file
+         nulgg = 17
+C* NINENN weight and address file
+         nulgn = 18
+C     
+C     
+C*    2. Print comlun
+C        ------------
+C     
+         IF (nlogprt .GE. 1) THEN 
+            WRITE (UNIT = nulou,FMT ='(
+     $           '' nulin ='',i3,'' nulou ='',i3,
+     $           '' nulgr ='',i3,'' nulma ='',i3,
+     $           '' nulsu ='',i3,'' nultr ='',i3,   
+     $           '' nulcc ='',i3,'' nulgg ='',i3,'' nulgn ='',i3,
+     $           '' nulan ='',i3,'' nulrd ='',i3,'' nudum ='',i3,/)')
+     $           nulin, nulou, nulgr, nulma, nulsu, 
+     $           nultr, nulcc, nulgg, nulgn, nulan, nulrd, nudum
+         ENDIF 
+C     
+C     
+C     
+C*    3. Assign unit numbers to input and output binary files
+C        ----------------------------------------------------
+C     
+         nluinp(1)=21
+         DO 310 jf = 2, ig_nfield
+            isamefic=0
+            DO 320 jj = 1, jf-1
+               IF (cficinp(jf) .eq. cficinp(jj)) THEN
+                  isamefic=1
+                  nluinp(jf) = nluinp(jj)
+               ENDIF
+ 320        CONTINUE
+            IF (isamefic .lt. 1) nluinp(jf) = 20 + jf
+ 310     CONTINUE
+C     
+C*    For PIPE technique only
+C     
+         IF (cchan. eq. 'PIPE' .or. cchan. eq. 'NONE') THEN
+            nluout(1)=21 + ig_nfield
+            DO 330 jf = 2, ig_nfield
+               DO 340 jj = 1, jf-1
+                  IF(cficout(jf) .eq. cficout(jj)) THEN
+                     nluout(jf) = nluout(jj)
+                  ELSE
+                     nluout(jf) = 20 + ig_nfield + jf
+                  ENDIF
+ 340           CONTINUE
+ 330        CONTINUE
+         ENDIF
+      ENDIF
+C
+C*     4. End of routine
+C         --------------
+C
+      IF (nlogprt .GE. 1) THEN 
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine inilun ---------'
+          CALL FLUSH (nulou)
+      ENDIF 
+      RETURN
+      END
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inipar.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inipar.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inipar.F	(revision 1677)
@@ -0,0 +1,1966 @@
+      SUBROUTINE inipar
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inipar*  - Get run parameters
+C
+C     Purpose:
+C     -------
+C     Reads and prints out run parameters.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inipar*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     parse
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C     Version Programmer  Date      Description
+C     ------- ----------  ----      -----------  
+C       1.0   L. Terray   94/01/01  created
+C       1.1   L. Terray   94/08/01  modified: change in namelist
+C                                   nice flag + new case for nmode
+C       1.1   L. Terray   94/10/01  modified: change printing
+C       2.0b  L. Terray   95/07/24  modified: new structure
+C       2.0   L. Terray   96/02/01  modified: lecture of cdqdt for
+C                                   subgrid and add mozaic analysis
+C                                   Lecture of a unit for filling
+C       2.1   L. Terray   96/09/25  Changes to mozaic and subgrid
+C                                   analysis, addition of nfend and
+C                                   nintflx, check[in-out] analysis
+C                                   addition of nointerp case.
+C       2.2   L. Terray   97/02/12  Printing bug on analysis sub-
+C                                   grid (SOLAR) corrected
+C       2.2   L. Terray   97/02/20  Printing bug on analysis ANAIS
+C                                   corrected
+C       2.2   L. Terray   97/12/14  Add new input: MODINFO and new
+C                                   extrapolation technique
+C       2.3   S. Valcke   99/03/14  cjobnam with 3 or 4 characters
+C       2.3   S. Valcke   99/03/25  troncature as NOxxxx in namcouple
+C       2.3   S. Valcke   99/03/30  READ/WRITE flag and dataset index
+C                                   for NINENN weights
+C       2.3   S. Valcke   99/04/30  NLOGPRT for printing levels
+C       2.3   L. Terray   99/09/15  changed periodicity variables
+C                                   and input them as field parameters
+C       2.4   J. Latour   99/10/28  Add new input: CHATYPE for type of
+C	    	     	   message passing : MPI2 or PVM3
+C       2.4   S. Valcke   2K/02/04  Additional readings for CLIM/MPI2
+C       2.5   S. Valcke   2K/09/04  Remove $MACHINE, clmach, cmach
+C       2.5   S. Valcke   2K/09/04  $CHATYPE in $CHANNEL
+C       2.5   S. Valcke   2K/09/05  Add input line with integral flag
+C                                   for  check[in-out], remove nintflx 
+C       2.5   S. Valcke   2K/09/05  Remove fld 3rd input line for CLIM
+C       2.5   S. Valcke   2K/09/08  Changed input lines for PVM3&MPI2 
+C       2.5   J. Latour   01/11/28  Add MPI1 startup
+C       2.5   A. Caubel   02/05/15  Mods for dynamic allocation
+C       2.5   S. Valcke   02/06/12  PVM3 no longer supported
+C       2.5   V. Gayler   01/09/20  Scrip-Remapping
+C       3.0   S. Legutke  03/04/24  proposal of CF compliant cfldlab entries
+C                                   added labels for echam5/mpi-om
+C                                   grouping into classes
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_parallel
+      USE mod_string
+      USE mod_analysis
+      USE mod_anais
+      USE mod_rainbow
+      USE mod_extrapol
+      USE mod_unitncdf
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_coast
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_clim
+#endif
+      USE mod_calendar
+      USE mod_hardware
+      USE mod_unit
+      USE mod_label
+      USE mod_printing
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Local declarations --------------------
+C
+      CHARACTER*80 clline, clvari
+      CHARACTER*9 clword, clstring, clprint, clcal, clchan
+      CHARACTER*9 cljob, clmod, cltime, clseq, cldate, clhead
+      CHARACTER*8 cl_print_trans, cl_print_state
+      CHARACTER*3 clinfo, clind
+      CHARACTER*1 clequa
+      CHARACTER*64 cl_cfname,cl_cfunit
+      INTEGER (kind=ip_intwp_p) iind, il_aux
+      INTEGER (kind=ip_intwp_p) il_file_unit, id_error
+      INTEGER (kind=ip_intwp_p) il_max_entry_id, il_no_of_entries
+      INTEGER (kind=ip_intwp_p) il_i, il_pos
+      LOGICAL llseq, lldel, llxts, lllag, ll_exist
+      INTEGER lastplace
+C
+C* ---------------------------- Poema verses --------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Get basic info for the simulation 
+C        ---------------------------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE inipar  -  Level 0'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' Initialization of run parameters'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' Reading input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Initialize character keywords to locate appropriate input
+C
+      clstring = ' $STRINGS'
+      cljob    = ' $JOBNAME'
+      clchan   = ' $CHANNEL'
+      clmod    = ' $NBMODEL'
+      cltime   = ' $RUNTIME'
+      clseq    = ' $SEQMODE'
+      cldate   = ' $INIDATE'
+      clhead   = ' $MODINFO'
+      clprint  = ' $NLOGPRT'
+      clcal    = ' $CALTYPE'
+C
+C* Initialize some variables 
+      ndate = 0 ; nmseq = 1 ; ntime = 432000 ; niter = 5 
+      nstep = 86400 ; nitfn=4
+      cjobnam = 'DEF'
+      lmodinf = .TRUE. 
+
+C
+C* CF long names for exchange fields
+      INQUIRE (file='cf_name_table.txt', exist=ll_exist)
+
+      IF (ll_exist) THEN
+          WRITE (nulou,*) 'inipar: Reading CF name table!'
+          il_file_unit = 99
+          OPEN (file='cf_name_table.txt', unit=il_file_unit, 
+     $        form='formatted', status='old')
+
+          READ (unit=il_file_unit,fmt=*,iostat=id_error)
+          READ (unit=il_file_unit,fmt=*,iostat=id_error) 
+     $        il_max_entry_id, il_no_of_entries
+
+          IF (id_error.ne.0) THEN 
+              WRITE (nulou,*) 'inipar :cf_name_table.txt:' 
+     $            ,' Reading of first record failed!'
+              CALL halte('STOP in inipar')
+          ENDIF
+
+          IF (il_max_entry_id.gt.0) THEN 
+              allocate (cfldlab(1:il_max_entry_id),STAT=id_error)
+              IF (id_error.ne.0) THEN 
+                  write(nulou,*) 'inipar: Allocation of cfldlab failed!'
+                  CALL halte('STOP in inipar')
+              ENDIF
+          ELSE
+              WRITE (nulou,*) 'inipar: cf_name_table.txt:', 
+     $            'The number of entries is less than 0 !'
+              CALL halte('STOP in inipar')                
+          ENDIF
+
+          READ (unit=il_file_unit,fmt=*,iostat=id_error)
+          DO il_i=1,il_no_of_entries
+            READ (unit=il_file_unit,fmt=*,iostat=id_error) 
+     $          il_pos,cl_cfname,cl_cfunit
+
+            IF (id_error.eq.0) THEN 
+                IF (il_pos .le. il_max_entry_id) THEN 
+                    cfldlab(il_pos)=trim(cl_cfname)
+                ELSE
+                    WRITE (nulou,*) 'inipar: cf_name_table.txt:',
+     $               'Record ',il_i,': numlab =',il_pos,' out of range!'
+                    CALL halte('STOP in inipar')  
+                ENDIF
+            ELSE
+                WRITE (nulou,*) 'inipar: cf_name_table.txt:',
+     $              'Reading record ',il_i,' failed!'
+                CALL halte('STOP in inipar') 
+            ENDIF
+          END DO
+      ELSE
+          WRITE (nulou,*) 'inipar: cf_name_table.txt missing'
+          CALL halte('STOP in inipar') 
+      ENDIF
+      CLOSE(il_file_unit)
+C
+C* First get experiment name 
+C
+      REWIND nulin
+ 100  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 110) clword
+      IF (clword .NE. cljob) GO TO 100
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $JOBNAME '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE IF (ilen .GT. 0 .AND. ilen .NE. 3 .AND. ilen .NE .4 ) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $JOBNAME variable spelling '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE
+          IF (ilen .EQ. 3) THEN
+              WRITE (cjobnam,FMT='(A1,A3)') ' ',clvari
+          ELSE IF (ilen .EQ. 4) THEN
+              WRITE (cjobnam,FMT='(A4)') clvari
+          ENDIF
+      ENDIF
+C 
+C* Print out experiment name
+C
+      CALL prcout
+     $    ('The experiment name for this run is cjobnam =', cjobnam,1)
+C
+C* Get number of models involved in this simulation
+C
+      REWIND nulin
+ 120  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 130) clword
+      IF (clword .NE. clmod) GO TO 120
+      READ (UNIT = nulin,FMT = 1002) clline
+C
+C* Get model names
+C
+      DO 140 jm = 1, ig_nmodel
+        imodel = jm + 1
+        CALL parse (clline, clvari, imodel, jpeighty, ilen)
+        cmodnam(jm) = clvari
+C
+C* Print out model names
+C
+        WRITE (UNIT = nulou,FMT ='
+     $      (''   Name for model '',I1,'' is '',A6,/)') 
+     $      jm, cmodnam(jm)
+ 140  CONTINUE
+C
+C* Get model maximum unit number used if they appear on the line
+C
+      DO 142 jm = 1, ig_nmodel
+        imodel = jm + 1 + ig_nmodel
+        CALL parse (clline, clvari, imodel, jpeighty, ilen)
+        IF (ilen .gt. 0) THEN
+            READ (clvari,FMT = 1004) iga_unitmod(jm)
+C
+C* Print out model minimum logfile unit number
+C
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT=nulou,FMT='(''The maximum Fortran unit number'',
+     $          '' used in model'', I2, '' is '', I2)')
+     $          jm, iga_unitmod(jm)
+            WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Verify that maximum unit number is larger than 1024; 
+C* if not, use 1024.
+            IF (iga_unitmod(jm) .lt. 1024) iga_unitmod(jm)=1024
+        ELSE
+            WRITE (UNIT = nulou, FMT = *)
+     $      ' WARNING: You did not give in the namcouple the maximum',
+     $      ' Fortran unit numbers used in your models.',
+     $      ' Oasis will suppose that units above 1024 are free !'
+            iga_unitmod(jm)=1024
+        ENDIF
+ 142      CONTINUE
+C
+C* Get hardware info for this OASIS simulation
+C
+      REWIND nulin
+ 160  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 170) clword
+      IF (clword .NE. clchan) GO TO 160
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL skip(clline, jpeighty)
+      IF(cchan .EQ. 'MPI2' .OR. cchan .EQ. 'MPI1') THEN
+C* Get one additional line for each model
+          DO 186 jm = 1, ig_nmodel
+            READ (UNIT = nulin,FMT = 1002) clline
+C*    Get the total number of processors for the model
+            CALL parse (clline, clvari, 1, jpeighty, ilen)
+            READ (clvari,FMT = 1003) nbtotproc(jm)
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT=nulou,FMT='(''The total number of processors'',
+     $'' for model'', I2, '' is'', I2)')
+     $ jm, nbtotproc(jm)
+            WRITE (UNIT = nulou,FMT = *) ' '
+C
+C*    Get the nbr of processors involved in the coupling for the model
+            CALL parse (clline, clvari, 2, jpeighty, ilen)
+            IF (ilen .LE. 0) THEN
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $     'No input for number of processors involved in the coupling'
+                WRITE (UNIT = nulou,FMT = *) 'for model', jm
+                WRITE (UNIT = nulou,FMT = *)
+     $         'Total number of processors will be used'
+                nbcplproc(jm)=nbtotproc(jm)
+            ELSE
+                READ (clvari,FMT = 1003) nbcplproc(jm)
+            ENDIF
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT ='(''The number of processors'',
+     $'' involved in the coupling for model'', I2, '' is'', I2)')
+     $ jm, nbcplproc(jm)
+           WRITE (UNIT = nulou,FMT = *) ' '
+C
+C*    Get the launching arguments for the model
+C
+            CALL parseblk (clline, clvari, 3, jpeighty, ilen)
+            IF (ilen .LE. 0) THEN
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $     'No launching argument for model', jm
+                WRITE (UNIT = nulou,FMT = *) ' '
+                cmpiarg(jm)=' '
+            ELSE
+                cmpiarg(jm)=clvari
+                WRITE (UNIT = nulou,FMT = *) ' '
+                WRITE (UNIT =nulou,FMT='
+     $ (''The launching argument for model '', I2, '' is'')') jm
+                WRITE (UNIT = nulou,FMT = *) cmpiarg(jm)
+                WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 'ilen ',ilen
+            ENDIF
+            
+C
+ 186      CONTINUE
+C
+         ENDIF
+C
+C* Get total time for this simulation
+C
+      REWIND nulin
+ 190  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 191) clword
+      IF (clword .NE. cltime) GO TO 190
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $RUNTIME '
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Default value of 5 days will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE
+          READ (clvari,FMT = 1004) ntime
+      ENDIF
+C
+C* Print out total time
+C
+      CALL prtout
+     $    ('The total time for this run is ntime =', ntime, 1)
+C
+C* Get initial date for this simulation
+C
+      REWIND nulin
+ 192  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 193) clword
+      IF (clword .NE. cldate) GO TO 192
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $INIDATE '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE
+          READ (clvari,FMT = 1004) ndate
+      ENDIF
+C
+C* Print out initial date
+C
+      CALL prtout
+     $    ('The initial date for this run is ndate = ', ndate, 1)
+C
+C* Get number of sequential models involved in this simulation
+C
+      REWIND nulin
+ 194  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 195) clword
+      IF (clword .NE. clseq) GO TO 194
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $SEQMODE '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE IF (ilen .GT. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Sequential models are too many'
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $SEQMODE variable spelling '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+        ELSE
+          READ (clvari,FMT = 1003) nmseq
+      ENDIF
+C
+C* Print out the number of sequential models
+C
+      CALL prtout
+     $    ('The number of sequential fields is nmseq =', nmseq, 1)
+C
+C* Get the information mode for this simulation
+C
+      REWIND nulin
+ 196  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 197) clword
+      IF (clword .NE. clhead) GO TO 196
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $MODINFO '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+        ELSE IF (ilen .GT. 0 .AND. ilen .NE. 3) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Info mode uncorrectly specified'
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $MODINFO variable spelling '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+        ELSE
+          clinfo = clvari
+          IF (clinfo .EQ. 'YES') THEN 
+              lmodinf = .TRUE. 
+            ELSE 
+              lmodinf = .FALSE. 
+          ENDIF 
+      ENDIF
+C
+C* Print out the information mode
+C
+      CALL prcout
+     $    ('The information mode is activated ? ==>', clinfo, 1)
+C
+C* Get the printing level for this simulation
+C
+      REWIND nulin
+ 198  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 199) clword
+      IF (clword .NE. clprint) GO TO 198
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $NLOGPRT '
+          WRITE (UNIT = nulou,FMT = *) ' Default value 2 will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ELSE IF (ilen .NE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Printing level uncorrectly specified'
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $NLOGPRT variable spelling '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+      ELSE
+          READ (clvari,FMT = 1003) nlogprt
+      ENDIF
+C
+C* Print out the printing level
+C
+      CALL prtout
+     $    ('The printing level is nlogprt =', nlogprt, 1)
+C
+C* Get the calendar type for this simulation
+C
+      REWIND nulin
+ 200  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 201) clword
+      IF (clword .NE. clcal) GO TO 200
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $CALTYPE '
+          WRITE (UNIT = nulou,FMT = *) ' Default value 1 will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          ncaltype = 1
+      ELSE
+          READ (clvari,FMT = 1003) ncaltype
+      ENDIF
+C
+C* Print out the calendar type
+C
+      CALL prtout
+     $   ('The calendar type is ncaltype =', ncaltype, 1)
+      IF (ncaltype .EQ. 1) THEN
+          CALL prcout
+     $        ('Gregorian calendar', ' ', 1)
+      ELSE IF (ncaltype .EQ. 0) THEN
+          CALL prcout
+     $        ('365 day calendar (no leap years)', ' ', 1)
+      ELSE
+          CALL prtout
+     $        ('The number of days per month =', ncaltype, 1)
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(A9)
+ 1002 FORMAT(A80)
+ 1003 FORMAT(I3)
+ 1004 FORMAT(I8)
+C
+C*    2. Get field information
+C        ---------------------
+C
+C* Init. array needed for local transformation  
+C
+      ig_local_trans(:) = ip_instant
+C
+C* Init. arrays needed for ANAIS(G-M),mapping and subgrid interpolation
+C
+      IF (lg_oasis_field) THEN
+         lcoast = .TRUE.
+         DO 215 jz = 1, ig_nfield
+            linit(jz) = .TRUE.
+            lmapp(jz) = .TRUE.
+            lsubg(jz) = .TRUE.
+            lextra(jz) = .TRUE.
+            varmul(jz) = 1.
+            lsurf(jz) = .FALSE.
+ 215     CONTINUE 
+C     
+C* Initialize flag indicating IF EXTRAP/NINENN parameter sets have 
+C* already been calculated or read (.TRUE.) or not (.FALSE.)
+C     
+         DO 217 jfn = 1, ig_maxnfn
+            lweight(jfn) = .FALSE.
+ 217     CONTINUE
+      ENDIF
+C
+C* Get the SSCS for all fields
+C
+      REWIND nulin
+ 220  CONTINUE
+      READ (UNIT = nulin,FMT = 2001,END = 230) clword
+      IF (clword .NE. clstring) GO TO 220
+C
+C* Loop on total number of fields (NoF)
+C
+      DO 240 jf = 1, ig_total_nfield
+C
+C* Read first two lines of strings for field n = 1,2...,ig_total_nfield
+C      --->>> Main characteristics of fields
+C
+C* First line
+C
+         READ (UNIT = nulin,FMT = 2002) clline
+         CALL parse(clline, clvari, 1, jpeighty, ilen)
+C* Get output field symbolic name
+         cg_input_field(jf) = clvari
+        IF (lg_state(jf)) cnaminp(ig_number_field(jf)) = 
+     $        cg_input_field(jf)
+         IF (lg_state(jf)) cnamout(ig_number_field(jf)) = 
+     $        cg_output_field(jf)
+         CALL parse(clline, clvari, 3, jpeighty, ilen)
+C* Get field label number
+         READ (clvari,FMT = 2003) ig_numlab(jf)
+         IF (lg_state(jf)) numlab(ig_number_field(jf)) = ig_numlab(jf)
+         CALL parse(clline, clvari, 4, jpeighty, ilen)
+C* Get field exchange frequency
+         IF (clvari(1:4) .eq. 'ONCE') THEN
+C
+C* The case 'ONCE' means that the coupling period will be equal to the 
+C* time of the simulation
+C
+            ig_freq(jf) = ntime
+         ELSE
+         READ (clvari,FMT = 2004) ig_freq(jf)
+         IF (ig_freq(jf) .eq. 0) THEN
+            GOTO 236
+         ELSEIF (ig_freq(jf) .gt. ntime) THEN
+           WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+           WRITE (UNIT = nulou,FMT = *) 
+     $          'The coupling period of the field ',jf
+           WRITE (UNIT = nulou,FMT = *) 
+     $          'is greater than the time of the simulation '
+           WRITE (UNIT = nulou,FMT = *) 
+     $          'This field will not be exchanged !'
+         ENDIF
+         ENDIF
+         IF (lg_state(jf)) nfexch(ig_number_field(jf)) = ig_freq(jf)
+C* Fill up restart file number and restart file name arrays
+         IF (jf.eq.1) THEN
+            il_aux = 1
+            ig_no_rstfile(jf) = 1
+            cg_name_rstfile (ig_no_rstfile(jf)) = cg_restart_file(jf)
+         ELSEIF (jf.gt.1) THEN
+            IF (ALL(cg_name_rstfile.ne.cg_restart_file(jf))) THEN
+               il_aux = il_aux + 1
+               ig_no_rstfile(jf) = il_aux
+               cg_name_rstfile (ig_no_rstfile(jf))= cg_restart_file(jf)
+            ELSE 
+               DO ib = 1, jf - 1 
+                  IF(cg_name_rstfile(ig_no_rstfile(ib)).eq.
+     $                 cg_restart_file(jf)) THEN
+                     ig_no_rstfile(jf) = ig_no_rstfile(ib)
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDIF
+         CALL parse(clline, clvari, 7, jpeighty, ilen)
+C* For all techniques beside PIPE and NONE technique, get eventually
+C* the field STATUS
+         IF (cchan .ne. 'PIPE' .and. cchan .ne. 'NONE') THEN
+             IF (clvari(1:8).eq.'EXPORTED' .or. 
+     $           clvari(1:8).eq.'AUXILARY') THEN
+                 cstate(ig_number_field(jf)) = clvari
+             ELSEIF (clvari(1:6) .eq. 'EXPOUT') THEN
+                 cstate(ig_number_field(jf)) = 'EXPORTED'
+             ENDIF
+C*
+         ELSE
+            IF (lg_state(jf)) cficout(ig_number_field(jf)) = clvari
+C*          Get field status
+            CALL parse(clline, clvari, 8, jpeighty, ilen)
+            IF (lg_state(jf)) cstate(ig_number_field(jf)) = clvari
+            IF (lg_state(jf)) then
+            IF (cstate(ig_number_field(jf)) .ne. 'EXPORTED'
+     $          .and. cstate(ig_number_field(jf)) .ne. 'AUXILARY') THEN
+                CALL prtout 
+     $              ('Error in namcouple for status of field',jf,1)
+                WRITE (UNIT = nulou,FMT = *) 
+     $              '==> Must be EXPORTED or AUXILARY'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              'Maybe you forgot the output FILE name which'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              'is mandatory for PIPE or NONE techniques'
+                CALL HALTE('STOP in inipar') 
+            ENDIF
+            ENDIF
+        ENDIF
+C
+C* Second line
+C
+        IF (ig_total_state(jf) .ne. ip_input) THEN
+           READ (UNIT = nulin,FMT = 2002) clline
+C     *      First determine what information is on the line
+           CALL parse(clline, clvari, 3, jpeighty, ilen)
+           IF (ilen .lt. 0) THEN
+C     *          IF only two words on the line, then they are the locator 
+C     *          prefixes and the grids file must be in NetCDF format       
+              ig_lag(jf)=0
+              ig_total_nseqn(jf)=1
+              IF (lg_state(jf)) then
+                  nseqn(ig_number_field(jf)) = 1
+                  nlagn(ig_number_field(jf)) = 0
+              ENDIF
+              llseq=.FALSE.
+              lldel=.FALSE.
+              llxts=.FALSE.
+              lllag=.FALSE.
+              WRITE (UNIT=nulou,FMT=3043) jf
+              IF(nmseq .gt. 1 .and. .not. llseq) GO TO 231
+           ELSE 
+              READ(clvari,FMT = 2011) clind, clequa, iind
+              IF (clind .EQ. 'SEQ' .or. clind .EQ. 'DEL' .or. 
+     $             clind .eq. 'XTS' .or. clind .EQ. 'LAG' .and.
+     $             clequa .EQ. '=') THEN
+C     *              If 3rd word is an index, then first two words are 
+C     *              locator prefixes and grids file must be NetCDF format
+                 ilind1=3
+                 ilind2=6
+              ELSE
+C     *              If not, the first 4 words are grid dimensions and next
+C     *              2 words are locator prefixes, and grids file may be or
+C     *              not in NetCDF FORMAT.
+                 ilind1=7
+                 ilind2=10
+              ENDIF
+C     *          Get possibly additional indices
+              ig_lag(jf)=0
+              ig_total_nseqn(jf)=1
+              IF (lg_state(jf)) then
+                  nseqn(ig_number_field(jf)) = 1
+                  nlagn(ig_number_field(jf)) = 0
+              ENDIF
+              llseq=.FALSE.
+              lldel=.FALSE.
+              llxts=.FALSE.
+              lllag=.FALSE.
+C     
+              DO 245 ilind=ilind1, ilind2
+                 CALL parse(clline, clvari, ilind, jpeighty, ilen)
+                 IF(ilen .eq. -1) THEN
+                    IF (nlogprt .EQ. 2) THEN 
+C                       IF(.not. lldel) WRITE (UNIT=nulou,FMT=3039) jf
+C                       IF(.not. llxts) WRITE (UNIT=nulou,FMT=3040) jf
+                       IF(.not. lllag) WRITE (UNIT=nulou,FMT=3043) jf
+                    ENDIF
+                    IF(nmseq .gt. 1 .and. .not. llseq) GO TO 231
+                    GO TO 247
+                 ELSE
+                    READ(clvari,FMT = 2011) clind, clequa, iind
+                    IF (clind .EQ. 'SEQ') THEN
+                       IF (iind .gt. nmseq) THEN
+                          GO TO 232
+                       ELSE IF (iind .eq. 0) THEN
+                          GO TO 234
+                       ELSE
+                          ig_total_nseqn(jf)=iind
+                          IF (lg_state(jf))
+     $                        nseqn(ig_number_field(jf)) = iind
+                          llseq=.TRUE.
+                       ENDIF
+                    ELSE IF (clind .eq. 'LAG') THEN
+                       ig_lag(jf)=iind
+                       IF (lg_state(jf))
+     $                     nlagn(ig_number_field(jf)) = iind
+                       lllag=.TRUE.
+                       WRITE (UNIT = nulou,FMT = 3044)jf,ig_lag(jf)
+                    ENDIF              
+                 ENDIF
+ 245          CONTINUE
+          ENDIF
+       ENDIF
+
+C
+ 247    CONTINUE
+C
+C* Third line
+C
+        IF (lg_state(jf)) THEN
+           READ (UNIT = nulin,FMT = 2002) clline
+           CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get source grid periodicity type
+           csper(ig_number_field(jf)) = clvari
+           IF(csper(ig_number_field(jf)) .NE. 'P' .AND. 
+     $          csper(ig_number_field(jf)) .NE. 'R') THEN
+              CALL prtout
+     $      ('ERROR in namcouple for source grid type of field', jf, 1)
+              WRITE (UNIT = nulou,FMT = *) '==> must be P or R'
+              CALL HALTE('STOP in inipar')
+           ENDIF
+C     
+           CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get nbr of overlapped longitudes for the Periodic type source grid
+           READ(clvari,FMT = 2005) nosper(ig_number_field(jf))
+           CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get target grid periodicity type
+           ctper(ig_number_field(jf)) = clvari
+           IF(ctper(ig_number_field(jf)) .NE. 'P' .AND. 
+     $          ctper(ig_number_field(jf)) .NE. 'R') THEN
+              CALL prtout
+     $      ('ERROR in namcouple for target grid type of field', jf, 1)
+              WRITE (UNIT = nulou,FMT = *) '==> must be P or R'
+              CALL HALTE('STOP in inipar')
+           ENDIF
+C     
+           CALL parse(clline, clvari, 4, jpeighty, ilen)
+C     * Get nbr of overlapped longitudes for the Periodic type target grid
+           READ(clvari,FMT = 2005) notper(ig_number_field(jf))
+C     
+C     Define stuff related to parallel decomposition. For now, as oasis
+C     is always monoproc, cparal(ig_number_field(jf))='SERIAL'. 
+C     
+           IF (cchan .EQ. 'MPI2' .OR. cchan .EQ. 'MPI1') THEN
+              cparal(ig_number_field(jf)) = 'SERIAL'
+           ENDIF
+       ENDIF
+C
+C* Get the local transformation
+C
+        IF (.not. lg_state(jf)) THEN
+           IF (ig_total_state(jf) .ne. ip_input .and. 
+     $          ig_total_ntrans(jf) .gt. 0 ) THEN
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+              DO ja=1,ig_total_ntrans(jf)
+                 READ (UNIT = nulin,FMT = 2002) clline 
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+                 IF (clvari(1:7) .eq. 'INSTANT') THEN 
+                    ig_local_trans(jf) = ip_instant
+                 ELSEIF (clvari(1:7) .eq. 'AVERAGE') THEN
+                    ig_local_trans(jf) = ip_average
+                 ELSEIF (clvari(1:7) .eq. 'ACCUMUL') THEN
+                    ig_local_trans(jf) = ip_accumul
+                 ELSEIF (clvari(1:5) .eq. 'T_MIN') THEN
+                    ig_local_trans(jf) = ip_min
+                 ELSEIF (clvari(1:5) .eq. 'T_MAX') THEN
+                    ig_local_trans(jf) = ip_max   
+                 ELSE
+                    CALL prtout
+     $ ('ERROR in namcouple for local transformations of field', jf, 1)
+                    WRITE (UNIT = nulou,FMT = *) 
+     $    '==> Must be INSTANT, AVERAGE, ACCUMUL, T_MIN or T_MAX'
+                    CALL HALTE('STOP in inipar')  
+                 ENDIF
+              ENDDO
+           ENDIF
+       ELSE
+         READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+C     
+C     * Now read specifics for each transformation
+C 
+           DO 270 ja = 1, ig_ntrans(ig_number_field(jf))
+C     
+C     * Read next line unless if analysis is NOINTERP (no input)
+C     
+              IF(canal(ja,ig_number_field(jf)) .NE. 'NOINTERP') THEN 
+                 READ (UNIT = nulin,FMT = 2002) clline
+                 CALL skip(clline, jpeighty)
+              ENDIF
+              IF (canal(ja,ig_number_field(jf)) .EQ. 'LOCTRANS') THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+                 IF (clvari(1:7) .eq. 'INSTANT') THEN 
+                    ig_local_trans(jf) = ip_instant
+                 ELSEIF (clvari(1:7) .eq. 'AVERAGE') THEN
+                    ig_local_trans(jf) = ip_average
+                 ELSEIF (clvari(1:7) .eq. 'ACCUMUL') THEN
+                    ig_local_trans(jf) = ip_accumul
+                 ELSEIF (clvari(1:5) .eq. 'T_MIN') THEN
+                    ig_local_trans(jf) = ip_min
+                 ELSEIF (clvari(1:5) .eq. 'T_MAX') THEN
+                    ig_local_trans(jf) = ip_max   
+                 ELSE
+                    CALL prtout
+     $ ('ERROR in namcouple for local transformations of field', jf, 1)
+                    WRITE (UNIT = nulou,FMT = *) 
+     $    '==> Must be INSTANT, AVERAGE, ACCUMUL, T_MIN or T_MAX'
+                    CALL HALTE('STOP in inipar')  
+                 ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MASK') THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get mask value
+                 READ(clvari,FMT = 2006) amskval(ig_number_field(jf))
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MASKP') THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get the Mask value for the output field
+                 READ(clvari,FMT = 2006)amskvalnew(ig_number_field(jf))
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MOZAIC')THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get file name for grid mapping
+                 cgrdmap(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get related logical unit 
+                 READ(clvari,FMT = 2005) nlumap(ig_number_field(jf))
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'INVERT')THEN
+                 ig_invert(jf) = 1
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get lat-lon ordering for initial fields
+                 cxordbf(ig_number_field(jf)) = clvari
+                 IF(trim(adjustl(clvari)).eq.'NORSUD')
+     $                    ig_invert(jf)=ig_invert(jf)+1
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+                 cyordbf(ig_number_field(jf)) = clvari
+                 IF(trim(adjustl(clvari)).eq.'ESTWST')
+     $                    ig_invert(jf)=ig_invert(jf)+2
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKIN')THEN
+C     * Get field integral flag
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+                 READ(clvari,FMT = 2010) clind, clequa, 
+     $                ntinpflx(ig_number_field(jf))
+                 IF(clind .NE. 'INT') GO TO 235
+                 IF (ntinpflx(ig_number_field(jf)) .eq. 1) 
+     $                lsurf(ig_number_field(jf))= .TRUE. 
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKOUT') 
+     $                THEN
+C     *Get field integral flag
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+                 READ(clvari,FMT = 2010) clind, clequa, 
+     $                ntoutflx(ig_number_field(jf))
+                 IF(clind .NE. 'INT') GO TO 235
+                 IF (ntoutflx(ig_number_field(jf)) .eq. 1) 
+     $                lsurf(ig_number_field(jf))= .TRUE.
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'NOINTERP') 
+     $                THEN
+C     * No interpolation case
+                 CONTINUE
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'REVERSE') 
+     $                THEN
+                 ig_reverse(jf) = 1
+C     * Get lat-lon ordering for final fields
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+                 cxordaf(ig_number_field(jf)) = clvari
+                 IF(trim(adjustl(clvari)).eq.'NORSUD')
+     $                    ig_reverse(jf)=ig_reverse(jf)+1
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+                 cyordaf(ig_number_field(jf)) = clvari
+                 IF(trim(adjustl(clvari)).eq.'ESTWST')
+     $                    ig_reverse(jf)=ig_reverse(jf)+2
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'EXTRAP')THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get extrapolation method
+                 cextmet(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get number of neighbors used in extrapolation
+C     If extrapolation method is NINENN, next variable is the MINIMUM
+C     number of neighbors required (among the 8 closest) to perform
+C     the extrapolation (cannot be greater than 4 for convergence). 
+C     In case it is WEIGHT, it is the MAXIMUM number
+C     of neighbors required by the extrapolation operation.
+C     
+                 READ(clvari,FMT = 2003) neighbor(ig_number_field(jf))
+                 IF (cextmet(ig_number_field(jf)) .EQ. 'NINENN' .AND. 
+     $                neighbor(ig_number_field(jf)) .GT. 4) THEN
+                    neighbor(ig_number_field(jf))=4
+                    WRITE(UNIT = nulou,FMT = *) '        ***WARNING***'
+                    WRITE(UNIT = nulou,FMT = *) 
+     $                   'For EXTRAP/NINENN extrapolation' 
+                    WRITE(UNIT = nulou,FMT = *) 
+     $                   'the number of neighbors has been set to 4'
+                 ENDIF
+C     * If choice is NINENN, read one more data
+                 IF (cextmet(ig_number_field(jf)) .EQ. 'NINENN') THEN
+                    CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get NINENN weights read/write flag
+                    READ(clvari,FMT = 2005) niwtn(ig_number_field(jf))
+                 ENDIF
+C     * If choice is WEIGHT, read more data
+                 IF (cextmet(ig_number_field(jf)) .EQ. 'WEIGHT') THEN
+                    CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get file name for grid mapping
+                    cgrdext(ig_number_field(jf)) = clvari
+                    CALL parse(clline, clvari, 4, jpeighty, ilen)
+C     * Get related logical unit 
+                    READ(clvari,FMT = 2005) nluext(ig_number_field(jf))
+                 ENDIF 
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'INTERP')THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get interpolation method
+                 cintmet(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get source grid type
+                 cgrdtyp(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get field type (scalar or vector)
+                 cfldtyp(ig_number_field(jf)) = clvari
+C     * If interpolation uses ANAIS(G-M), read in more data
+                 IF (cintmet(ig_number_field(jf)) .EQ. 'SURFMESH') THEN
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C     * Get Anaism weights read/write flag
+                    READ(clvari,FMT = 2005) niwtm(ig_number_field(jf))
+                 ENDIF 
+                 IF (cintmet(ig_number_field(jf)) .EQ. 'GAUSSIAN') THEN
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C     * Read variance multiplicator for gaussian weights
+                    READ(clvari,FMT = 2006) varmul(ig_number_field(jf))
+                    CALL parse(clline, clvari, 7, jpeighty, ilen)
+C     * Get Anaisg weights read/write flag
+                    READ(clvari,FMT = 2005) niwtg(ig_number_field(jf))
+                 ENDIF
+          ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR') THEN
+C* Get Scrip remapping method
+              CALL parse(clline, clvari, 1, jpeighty, ilen)
+              READ(clvari,FMT = 2009) cmap_method(ig_number_field(jf))
+C* Get source grid type
+              CALL parse(clline, clvari, 2, jpeighty, ilen)
+              READ(clvari,FMT = 2009) cgrdtyp(ig_number_field(jf))
+              IF (cmap_method(ig_number_field(jf)) .eq. 'BICUBIC' 
+     $            .and. cgrdtyp(ig_number_field(jf)) .ne. 'LR'
+     $            .and. cgrdtyp(ig_number_field(jf)) .ne. 'D') THEN
+                  WRITE (UNIT = nulou,FMT = *) '    '
+                  CALL prtout
+     $                ('ERROR in namcouple for type of field', jf, 1)
+                  WRITE (UNIT = nulou,FMT = *) 
+     $    'BICUBIC interpolation cannot be used if grid is not LR or D'
+                  CALL HALTE('STOP in inipar') 
+              ENDIF
+              IF (cmap_method(ig_number_field(jf)) .eq. 'BILINEAR' 
+     $            .and. cgrdtyp(ig_number_field(jf)) .ne. 'LR'
+     $            .and. cgrdtyp(ig_number_field(jf)) .ne. 'D') THEN
+                  WRITE (UNIT = nulou,FMT = *) '    '
+                  CALL prtout
+     $                ('ERROR in namcouple for type of field', jf, 1)
+                  WRITE (UNIT = nulou,FMT = *) 
+     $    'BILINEAR interpolation cannot be used if grid is not LR or D'
+                  CALL HALTE('STOP in inipar') 
+              ENDIF
+C* Get field type (scalar/vector)
+              CALL parse(clline, clvari, 3, jpeighty, ilen)
+              READ(clvari,FMT = 2009) cfldtype(ig_number_field(jf))
+              IF(cfldtype(ig_number_field(jf)) .NE. 'SCALAR' .AND. 
+     $             cfldtype(ig_number_field(jf)) .NE. 'VECTOR' .AND.
+     $             cfldtype(ig_number_field(jf)) .NE. 'VECTOR_I' .AND.
+     $             cfldtype(ig_number_field(jf)) .NE. 'VECTOR_J') THEN
+                  WRITE (UNIT = nulou,FMT = *) '    '
+                  CALL prtout
+     $                ('ERROR in namcouple for type of field', jf, 1)
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                '==> must be SCALAR, VECTOR_I or VECTOR_J'
+                  CALL HALTE('STOP in inipar')
+              ENDIF
+C* Get restriction type for SCRIP search
+              CALL parse(clline, clvari, 4, jpeighty, ilen)
+              READ(clvari,FMT = 2009) crsttype(ig_number_field(jf))
+              IF (cgrdtyp(ig_number_field(jf)) .EQ. 'D') THEN
+                  IF (cmap_method(ig_number_field(jf)) .EQ. 'BILINEAR'
+     $                    .or.
+     $                 cmap_method(ig_number_field(jf)) .EQ. 'BICUBIC')
+     $                    THEN
+                      IF (crsttype(ig_number_field(jf)) .NE. 'LATITUDE')
+     $                    THEN
+                          WRITE (UNIT = nulou,FMT = *) '    '
+                          CALL prtout
+     $             ('ERROR in namcouple for restriction of field',jf,1)
+                          WRITE (UNIT = nulou,FMT = *) 
+     $             '==> LATITUDE must be chosen for reduced grids (D)'
+                          CALL HALTE('STOP in inipar')
+                      ELSE  
+                          crsttype(ig_number_field(jf)) = 'REDUCED'
+                      ENDIF
+                  ENDIF
+              ENDIF
+C
+              IF(crsttype(ig_number_field(jf)) .NE. 'LATITUDE' .AND. 
+     $            crsttype(ig_number_field(jf)) .NE. 'LATLON' .AND.
+     $            crsttype(ig_number_field(jf)) .NE. 'REDUCED') THEN
+                  WRITE (UNIT = nulou,FMT = *) '    '
+                  CALL prtout
+     $            ('ERROR in namcouple for restriction of field',jf,1)
+                  WRITE (UNIT = nulou,FMT = *) 
+     $                '==> must be LATITUDE or LATLON'
+                  CALL HALTE('STOP in inipar')
+              ENDIF
+C*
+C* Get number of search bins for SCRIP search
+              CALL parse(clline, clvari, 5, jpeighty, ilen)
+              READ(clvari,FMT = 2003) nbins(ig_number_field(jf))
+C* Get normalize option for CONSERV
+              IF (cmap_method(ig_number_field(jf)) .EQ. 'CONSERV') THEN
+                  CALL parse(clline, clvari, 6, jpeighty, ilen)
+                  READ(clvari,FMT = 2009)cnorm_opt(ig_number_field(jf))
+                  IF (cnorm_opt(ig_number_field(jf)) .NE. 'FRACAREA'
+     $                .AND. 
+     $		      cnorm_opt(ig_number_field(jf)) .NE. 'DESTAREA' 
+     $                .AND. 
+     $                cnorm_opt(ig_number_field(jf)) .NE. 'FRACNNEI') 
+     $                THEN
+                      WRITE (UNIT = nulou,FMT = *) '    '
+                      CALL prtout
+     $        ('ERROR in namcouple for normalize option of field',jf,1)
+                      WRITE (UNIT = nulou, FMT = *) 
+     $                '==> must be FRACAREA, DESTAREA, or FRACNNEI'
+                      CALL HALTE('STOP in inipar')
+                  ENDIF
+C* Get order of remapping for CONSERV
+                  CALL parse(clline, clvari, 7, jpeighty, ilen)
+                  IF (ilen .LE. 0) THEN
+                      WRITE (UNIT = nulou,FMT = *) '    '
+                      CALL prtout
+     $        ('ERROR in namcouple for CONSERV for field',jf,1)
+                      WRITE (UNIT = nulou,FMT = *) 
+     $        '==> SECOND or FIRST must be indicated at end of line'
+                      CALL HALTE('STOP in inipar')
+                  ENDIF
+                  READ(clvari,FMT = 2009) corder(ig_number_field(jf))
+              ELSE
+                  cnorm_opt(ig_number_field(jf))='NONORM'
+              ENDIF
+C* Get number of neighbours for DISTWGT and GAUSWGT
+              IF (cmap_method(ig_number_field(jf)) .EQ. 'DISTWGT' .or.
+     $            cmap_method(ig_number_field(jf)) .EQ. 'GAUSWGT') THEN
+                  CALL parse(clline, clvari, 6, jpeighty, ilen)
+                  IF (ilen .LE. 0) THEN
+                      WRITE (UNIT = nulou,FMT = *) '    '
+                      CALL prtout
+     $        ('ERROR in namcouple for field',jf,1)
+                      WRITE (UNIT = nulou,FMT = *) 
+     $        '==> Number of neighbours must be indicated on the line'
+                      CALL HALTE('STOP in inipar')
+                  ELSE
+                    READ(clvari,FMT=2003)nscripvoi(ig_number_field(jf))
+                  ENDIF 
+              ENDIF
+C* Get gaussian variance for GAUSWGT
+              IF (cmap_method(ig_number_field(jf)) .EQ. 'GAUSWGT') THEN
+                  CALL parse(clline, clvari, 7, jpeighty, ilen)
+                  IF (ilen .LE. 0) THEN
+                      WRITE (UNIT = nulou,FMT = *) '    '
+                      CALL prtout
+     $        ('ERROR in namcouple for GAUSWGT for field',jf,1)
+                      WRITE (UNIT = nulou,FMT = *) 
+     $        '==> Variance must be indicated at end of line'
+                      CALL HALTE('STOP in inipar')
+                  ELSE
+                      READ(clvari,FMT=2006) varmul(ig_number_field(jf))
+                  ENDIF
+              ENDIF
+C*Get associated file name and information about rotation to cartesien
+              IF (cfldtype(ig_number_field(jf))=='VECTOR_I' .or.
+     $             cfldtype(ig_number_field(jf))=='VECTOR_J') THEN
+                 IF(cmap_method(ig_number_field(jf)) .EQ. 'DISTWGT')
+     $                lastplace=7
+                 IF(cmap_method(ig_number_field(jf)) .EQ. 'GAUSWGT')
+     $                lastplace=8
+                 IF(cmap_method(ig_number_field(jf)) .EQ. 'BILINEAR')
+     $                lastplace=6
+                 IF(cmap_method(ig_number_field(jf)) .EQ. 'BICUBIC')
+     $                lastplace=6
+                 IF(cmap_method(ig_number_field(jf)) .EQ. 'CONSERV')
+     $                lastplace=8
+                 CALL parse(clline, clvari, lastplace, jpeighty, ilen)
+                 IF (ilen .le. 0) THEN
+                      WRITE (UNIT = nulou,FMT = *) ' '
+                      WRITE (UNIT = nulou,FMT = *) 
+     $                    '==> A field associated must be indicated'
+                      CALL HALTE('STOP in inipar')
+                 ENDIF
+                 cg_assoc_input_field(ig_number_field(jf))=clvari
+C*Rotation?
+                 CALL parse(clline, clvari, lastplace+1, jpeighty, 
+     $                ilen) 
+                 IF (ilen .le. 0) THEN
+                    lrotate(ig_number_field(jf)) = .false.
+                 ELSEIF(clvari .le. 'PROJCART') THEN
+                    lrotate(ig_number_field(jf)) = .true.
+                    WRITE (UNIT = nulou,FMT = *)
+     $                   'rotation to cartesian for field : ', jf
+                 ELSE
+                    WRITE (UNIT = nulou,FMT = *) ' '
+                    CALL prtout
+     $                   ('ERROR in namcouple for vector in SCRIPR
+     $                   for field',jf,1)     
+                    WRITE (UNIT = nulou,FMT = *)
+     $                   'must be PROJCART or nothing' 
+                    CALL HALTE('STOP in inipar') 
+                 ENDIF
+              END IF
+C
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'FILLING') 
+     $                THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get data file name (used to complete the initial field array)
+                 cfilfic(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get logical unit connected to previous file
+                 READ(clvari,FMT = 2005) nlufil(ig_number_field(jf))
+                 CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get filling method
+                 cfilmet(ig_number_field(jf)) = clvari
+C     * If current field is SST
+                 IF(cfilmet(ig_number_field(jf))(4:6) .EQ. 'SST') THEN
+                    CALL parse(clline, clvari, 4, jpeighty, ilen)
+C     * Get flag for coast mismatch correction
+                    READ(clvari,FMT = 2005) nfcoast
+                    IF (cfilmet(ig_number_field(jf))(1:3) .EQ. 'SMO')
+     $                  THEN
+                        CALL parse(clline, clvari, 5, jpeighty, ilen)
+C     * Get field name for flux corrective term 
+                        cfldcor = clvari
+                        CALL parse(clline, clvari, 6, jpeighty, ilen)
+C     * Get logical unit used to write flux corrective term
+                        READ(clvari,FMT = 2005) nlucor
+                    ENDIF
+                 ENDIF 
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CONSERV') 
+     $                THEN            
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get conservation method
+                 cconmet(ig_number_field(jf)) = clvari
+                 lsurf(ig_number_field(jf)) = .TRUE.
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'REDGLO') THEN
+C     * Get extrapolation flag to go from reduced to global gaussian grid
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+                 cmskrd(ig_number_field(jf)) = clvari
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'GLORED') THEN
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get number of neighbors used in EXTRAP/NINENN extrapolation always
+C     performed within GLORED (cannot be greater than 4 for convergence).
+                 READ(clvari,FMT = 2003) neighborg(ig_number_field(jf))
+                 CALL parse(clline, clvari, 3, jpeighty, ilen)
+                 IF (neighborg(ig_number_field(jf)) .GT. 4) THEN
+                    neighborg(ig_number_field(jf))=4
+                    WRITE(UNIT = nulou,FMT = *) '        ***WARNING***'
+                    WRITE(UNIT = nulou,FMT = *) 
+     $                   'For EXTRAP/NINENN extrapolation in GLORED' 
+                    WRITE(UNIT = nulou,FMT = *) 
+     $                   'the number of neighbors has been set to 4'
+                 ENDIF
+C     * Get EXTRAP/NINENN weights read/write flag
+                 READ(clvari,FMT = 2005) niwtng(ig_number_field(jf))
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CORRECT') 
+     $                THEN
+C     * Get flux correction parameters
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get main field multiplicative coefficient
+                 READ(clvari,FMT = 2006) afldcoef(ig_number_field(jf))
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get number of auxilary fields in correction formula
+                 READ(clvari,FMT = 2003) ncofld (ig_number_field(jf))
+C     * Read auxilary field parameters
+                 icofld = ncofld(ig_number_field(jf))
+                 DO 280 jc = 1, icofld
+                    READ (UNIT = nulin,FMT = 2002) clline   
+                    CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get symbolic names for additional fields
+                    ccofld(jc,ig_number_field(jf)) = clvari
+                    CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get multiplicative coefficients for  additional fields
+                    READ(clvari,FMT = 2006) 
+     $                   acocoef (jc,ig_number_field(jf))
+                    CALL parse(clline, clvari, 3, jpeighty, ilen)
+C     * Get file names for external data files 
+                    ccofic(jc,ig_number_field(jf)) = clvari
+C     * Get related logical units 
+                    CALL parse(clline, clvari, 4, jpeighty, ilen)
+                    READ(clvari,FMT = 2005) 
+     $                   nludat(jc,ig_number_field(jf))
+ 280             CONTINUE
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD')THEN
+C     * Get linear combination parameters for initial fields
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get main field multiplicative coefficient
+                 READ(clvari,FMT = 2006) afldcobo(ig_number_field(jf))
+                 DO 290 jc = 1, nbofld(ig_number_field(jf))
+                    READ (UNIT = nulin,FMT = 2002) clline   
+                    CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get symbolic names for additional fields
+                    cbofld(jc,ig_number_field(jf)) = clvari
+                    CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get multiplicative coefficients for  additional fields
+                    READ(clvari,FMT = 2006) 
+     $                   abocoef (jc,ig_number_field(jf))
+ 290             CONTINUE
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW')THEN
+C     * Get linear combination parameters for final fields
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get main field multiplicative coefficient
+                 READ(clvari,FMT = 2006) afldcobn(ig_number_field(jf))
+                 DO 291 jc = 1, nbnfld(ig_number_field(jf))
+                    READ (UNIT = nulin,FMT = 2002) clline   
+                    CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get symbolic names for additional fields
+                    cbnfld(jc,ig_number_field(jf)) = clvari
+                    CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get multiplicative coefficients for  additional fields
+                    READ(clvari,FMT = 2006) 
+     $                   abncoef (jc,ig_number_field(jf))
+ 291             CONTINUE
+C     * Get fields to restore subgrid variability 
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SUBGRID')THEN
+                 CALL parse(clline, clvari, 1, jpeighty, ilen)
+C     * Get file name for subgrid interpolation
+                 cgrdsub(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+C     * Get related logical unit 
+                 READ(clvari,FMT = 2005) nlusub(ig_number_field(jf))
+                 CALL parse(clline, clvari, 5, jpeighty, ilen)
+C     * Get type of subgrid interpolation (solar or non solar flux)
+                 ctypsub(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 6, jpeighty, ilen)
+C     * Get additional field name on coarse grid
+                 cfldcoa(ig_number_field(jf)) = clvari
+                 CALL parse(clline, clvari, 7, jpeighty, ilen)
+C     * Get additional field name on fine grid
+                 cfldfin(ig_number_field(jf)) = clvari
+                 IF (ctypsub(ig_number_field(jf)) .EQ. 'NONSOLAR') THEN
+                    CALL parse(clline, clvari, 8, jpeighty, ilen)
+C     * Get coupling ratio on coarse grid
+                    cdqdt(ig_number_field(jf)) = clvari
+                 ENDIF 
+              ELSE 
+                 WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                 WRITE (UNIT = nulou,FMT = *)
+     $                ' Type of analysis not implemented yet '
+                 WRITE (UNIT = nulou,FMT = *) 
+     $                ' The analysis required in OASIS is :'
+                 WRITE (UNIT = nulou,FMT = *) ' canal = ', 
+     $                canal(ja,ig_number_field(jf))
+                 WRITE (UNIT = nulou,FMT = *) 
+     $                ' with ja = ', ja, ' jf = ', jf
+                 WRITE (UNIT = nulou,FMT = *) ' '
+                 CALL HALTE ('STOP in inipar')
+             ENDIF
+ 270       CONTINUE
+       ENDIF
+C
+C* End of loop on NoF
+C 
+ 240  CONTINUE
+C
+C*Get the associated number file for case vector
+C
+      DO jf = 1, ig_total_nfield
+         IF (cfldtype(ig_number_field(jf))=='VECTOR_I' .or.
+     $        cfldtype(ig_number_field(jf))=='VECTOR_J') THEN
+            DO jff = 1, ig_total_nfield
+               IF(cnaminp(ig_number_field(jff)) .eq.
+     $              cg_assoc_input_field(ig_number_field(jf)))THEN
+                  ig_assoc_input_field(ig_number_field(jf))=
+     $                 ig_number_field(jff)
+                  exit
+               ENDIF
+            ENDDO
+C
+C*Verify if interpolations are the same for the 2 components of the vector field
+C
+            IF(cmap_method(ig_number_field(jf)) .ne. 
+     $           cmap_method(ig_assoc_input_field(
+     $           ig_number_field(jf)))) THEN
+               WRITE (UNIT = nulou,FMT = *) 
+     $              'Interpolations must be the same for the 2'
+               WRITE (UNIT = nulou,FMT = *)
+     $              'components in vector case'
+               CALL HALTE('STOP in inipar')
+            END IF
+         ENDIF
+      ENDDO
+C
+C* Minimum coupling period
+C
+      ig_total_frqmin = iminim(ig_freq, ig_total_nfield)
+C
+C* Formats
+C
+ 2001 FORMAT(A9)
+ 2002 FORMAT(A80)
+ 2003 FORMAT(I4)
+ 2004 FORMAT(I8)
+ 2005 FORMAT(I2)
+ 2006 FORMAT(E15.6)
+ 2008 FORMAT(A2,I4)
+ 2009 FORMAT(A8)
+ 2010 FORMAT(A3,A1,I2)
+ 2011 FORMAT(A3,A1,I8)
+C
+C*    3. Printing
+C        --------
+C* Warning: no indentation for the next if (nightmare ...)
+      IF (nlogprt .GE. 1) THEN 
+      DO 310 jf = 1, ig_total_nfield
+         IF (ig_total_state(jf) .eq. ip_exported ) THEN
+            cl_print_state = 'EXPORTED'
+         ELSEIF (ig_total_state(jf) .eq. ip_ignored ) THEN
+            cl_print_state = 'IGNORED'
+         ELSEIF (ig_total_state(jf) .eq. ip_ignout ) THEN
+            cl_print_state = 'IGNOUT'
+         ELSEIF (ig_total_state(jf) .eq. ip_expout ) THEN 
+            cl_print_state = 'EXPOUT'
+         ELSEIF (ig_total_state(jf) .eq. ip_input ) THEN 
+            cl_print_state = 'INPUT'
+         ELSEIF (ig_total_state(jf) .eq. ip_output ) THEN 
+            cl_print_state = 'OUTPUT'
+         ELSEIF (ig_total_state(jf) .eq. ip_auxilary ) THEN 
+            cl_print_state = 'AUXILARY'
+         ENDIF
+         IF (ig_local_trans(jf) .eq. ip_instant) THEN
+            cl_print_trans = 'INSTANT'
+         ELSEIF (ig_local_trans(jf) .eq. ip_average) THEN
+             cl_print_trans = 'AVERAGE'
+         ELSEIF (ig_local_trans(jf) .eq. ip_accumul) THEN
+            cl_print_trans = 'ACCUMUL'
+         ELSEIF (ig_local_trans(jf) .eq. ip_min) THEN
+            cl_print_trans = 'T_MIN'
+         ELSEIF (ig_local_trans(jf) .eq. ip_max) THEN
+            cl_print_trans = 'T_MAX'   
+         ENDIF
+C* Local indexes
+      IF (.not. lg_state(jf)) THEN
+         ilab = ig_numlab(jf)
+         WRITE (UNIT = nulou,FMT = 3001) jf
+         WRITE (UNIT = nulou,FMT = 3002)
+         WRITE (UNIT = nulou,FMT = 3003)
+         WRITE (UNIT = nulou,FMT = 3004)
+         IF (ig_total_state(jf) .eq. ip_input .or. 
+     $        ig_total_state(jf) .eq. ip_output) THEN
+            WRITE (UNIT = nulou,FMT = 3121)
+     $           cg_input_field(jf), cg_output_field(jf), cfldlab(ilab), 
+     $           ig_freq(jf), cl_print_trans,
+     $           cl_print_state, ig_total_ntrans(jf)
+         ELSE  
+            WRITE (UNIT = nulou,FMT = 3116)
+     $           cg_input_field(jf), cg_output_field(jf), cfldlab(ilab), 
+     $           ig_freq(jf), cl_print_trans, ig_total_nseqn(jf), 
+     $           ig_lag(jf), cl_print_state, ig_total_ntrans(jf)
+         ENDIF
+      ELSE
+         ilab = numlab(ig_number_field(jf))
+         ifcb = ilenstr(cficbf(ig_number_field(jf)),jpeight)
+         ifca = ilenstr(cficaf(ig_number_field(jf)),jpeight)
+         WRITE (UNIT = nulou,FMT = 3001) jf
+         WRITE (UNIT = nulou,FMT = 3002)
+         WRITE (UNIT = nulou,FMT = 3003)
+         WRITE (UNIT = nulou,FMT = 3004) 
+         IF (cchan .EQ. 'MPI2' .OR. cchan .EQ. 'MPI1' ) THEN
+            WRITE (UNIT = nulou,FMT = 3005)
+     $           cnaminp(ig_number_field(jf)), 
+     $           cnamout(ig_number_field(jf)), cfldlab(ilab), 
+     $           nfexch(ig_number_field(jf)),
+     $           nseqn(ig_number_field(jf)),
+     $           ig_lag(jf),
+     $           cl_print_state,
+     $           ig_ntrans(ig_number_field(jf)), 
+     $           cparal(ig_number_field(jf))
+         ELSE
+               WRITE (UNIT = nulou,FMT = 3115)
+     $           cnaminp(ig_number_field(jf)), 
+     $           cnamout(ig_number_field(jf)), cfldlab(ilab), 
+     $           nfexch(ig_number_field(jf)),
+     $           nseqn(ig_number_field(jf)), 
+     $           cstate(ig_number_field(jf)), 
+     $           ig_ntrans(ig_number_field(jf))
+         ENDIF
+      ENDIF
+C* Warning: no indentation for the next if (nightmare ...)
+        IF (nlogprt .EQ. 2) THEN
+C* Warning: no indentation for the next if (nightmare ...)            
+        IF (.not. lg_state(jf)) THEN
+           IF (ig_total_state(jf) .eq. ip_ignored .or. 
+     $         ig_total_state(jf) .eq. ip_ignout ) THEN
+              WRITE (UNIT = nulou,FMT = 3117) cg_restart_file(jf)
+           ELSEIF (ig_total_state(jf) .eq. ip_input) THEN
+              WRITE (UNIT = nulou,FMT = 3118) cg_input_file(jf)
+           ENDIF
+        ELSE
+           IF (ig_total_state(jf) .eq. ip_exported .or. 
+     $          ig_total_state(jf) .eq. ip_expout .or. 
+     $          ig_total_state(jf) .eq. ip_auxilary )
+     $          WRITE (UNIT = nulou,FMT = 3117) cg_restart_file(jf)
+C* Warning: no indentation for the next if (nightmare ...)           
+        WRITE (UNIT = nulou,FMT = 3007)
+     $      csper(ig_number_field(jf)), nosper(ig_number_field(jf)), 
+     $      ctper(ig_number_field(jf)), notper(ig_number_field(jf))
+        WRITE (UNIT = nulou,FMT = 3008)
+     $      cficbf(ig_number_field(jf))(1:ifcb)//cglonsuf, 
+     $       cficbf(ig_number_field(jf))(1:ifcb)//cglatsuf,
+     $      cficbf(ig_number_field(jf))(1:ifcb)//cmsksuf, 
+     $       cficbf(ig_number_field(jf))(1:ifcb)//csursuf,
+     $      cficaf(ig_number_field(jf))(1:ifca)//cglonsuf, 
+     $       cficaf(ig_number_field(jf))(1:ifca)//cglatsuf,
+     $      cficaf(ig_number_field(jf))(1:ifca)//cmsksuf, 
+     $       cficaf(ig_number_field(jf))(1:ifca)//csursuf
+        WRITE (UNIT = nulou,FMT = 3009) 
+        WRITE (UNIT = nulou,FMT = 3010)
+        DO 320 ja = 1, ig_ntrans(ig_number_field(jf))
+          WRITE (UNIT = nulou,FMT = 3011) ja, 
+     $          canal(ja,ig_number_field(jf))
+          IF (canal(ja,ig_number_field(jf)) .EQ. 'MASK') THEN
+              WRITE(UNIT = nulou,FMT = 3012) 
+     $            amskval(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MASKP') THEN
+              WRITE(UNIT = nulou,FMT = 3042) 
+     $              amskvalnew(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'MOZAIC') THEN
+              WRITE(UNIT = nulou,FMT = 3013) 
+     $              cgrdmap(ig_number_field(jf)), 
+     $              nlumap(ig_number_field(jf)),
+     $              nmapfl(ig_number_field(jf)), 
+     $              nmapvoi(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'INVERT') THEN
+              WRITE(UNIT = nulou,FMT = 3014) 
+     $              cxordbf(ig_number_field(jf))
+              WRITE(UNIT = nulou,FMT = 3015) 
+     $             cyordbf(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'REVERSE') THEN
+              WRITE(UNIT = nulou,FMT = 3016) 
+     $              cxordaf(ig_number_field(jf))
+              WRITE(UNIT = nulou,FMT = 3017) 
+     $             cyordaf(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'EXTRAP') THEN
+              WRITE(UNIT = nulou,FMT = 3018) 
+     $              cextmet(ig_number_field(jf)), 
+     $              neighbor(ig_number_field(jf))
+              IF (cextmet(ig_number_field(jf)) .EQ. 'WEIGHT') THEN 
+                  WRITE(UNIT = nulou,FMT = 3019) 
+     $                cgrdext(ig_number_field(jf)), 
+     $                nluext(ig_number_field(jf)), 
+     $                nextfl(ig_number_field(jf))
+              ELSE IF (cextmet(ig_number_field(jf)) .EQ. 'NINENN') THEN 
+                  WRITE(UNIT = nulou,FMT = 3038) 
+     $                niwtn(ig_number_field(jf)), 
+     $                nninnfl(ig_number_field(jf))
+              ENDIF
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'INTERP') THEN
+              WRITE(UNIT = nulou,FMT = 3020) 
+     $              cintmet(ig_number_field(jf)), 
+     $              cgrdtyp(ig_number_field(jf)),
+     $              cfldtyp(ig_number_field(jf))
+              IF (cintmet(ig_number_field(jf)) .EQ. 'SURFMESH') THEN 
+                  WRITE(UNIT = nulou,FMT = 3021) 
+     $                naismfl(ig_number_field(jf)), 
+     $                naismvoi(ig_number_field(jf)), 
+     $                niwtm(ig_number_field(jf))
+              ENDIF 
+              IF (cintmet(ig_number_field(jf)) .EQ. 'GAUSSIAN') THEN 
+                  WRITE(UNIT = nulou,FMT = 3021) 
+     $                naisgfl(ig_number_field(jf)), 
+     $                naisgvoi(ig_number_field(jf)), 
+     $                niwtg(ig_number_field(jf))
+                  WRITE(UNIT = nulou,FMT = 3022) 
+     $                 varmul(ig_number_field(jf))
+              ENDIF
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR') THEN
+              WRITE(UNIT = nulou,FMT = 3045) 
+     $              cmap_method(ig_number_field(jf)), 
+     $              cfldtype(ig_number_field(jf)), 
+     $              cnorm_opt(ig_number_field(jf)),
+     $              crsttype(ig_number_field(jf)), 
+     $              nbins(ig_number_field(jf))
+              IF (cmap_method(ig_number_field(jf)) .EQ. 'CONSERV') THEN 
+                  WRITE(UNIT = nulou,FMT = 3046) 
+     $                corder(ig_number_field(jf))
+              ENDIF  
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'FILLING') THEN
+              WRITE(UNIT = nulou,FMT = 3023) 
+     $              cfilfic(ig_number_field(jf)), 
+     $              nlufil(ig_number_field(jf)),
+     $              cfilmet(ig_number_field(jf))
+              IF(cfilmet(ig_number_field(jf))(1:6) .EQ. 'SMOSST')
+     $            WRITE(UNIT = nulou,FMT = 3024) 
+     $            nfcoast, cfldcor, nlucor
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CONSERV') THEN            
+              WRITE(UNIT = nulou,FMT = 3025) 
+     $              cconmet(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'REDGLO') THEN
+              WRITE(UNIT = nulou,FMT = 3026) 
+     $              ntronca(ig_number_field(jf)), 
+     $              cmskrd(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CORRECT') THEN
+              WRITE(UNIT = nulou,FMT = 3027) 
+     $              cnamout(ig_number_field(jf)), 
+     $              afldcoef(ig_number_field(jf))
+              WRITE(UNIT = nulou,FMT=3028) ncofld(ig_number_field(jf))
+              icofld = ncofld(ig_number_field(jf))
+              DO 330 jc = 1, icofld
+                WRITE(UNIT = nulou,FMT = 3029) 
+     $              ccofic(jc,ig_number_field(jf)),
+     $                nludat(jc,ig_number_field(jf))
+                WRITE (UNIT = nulou,FMT = 3030) 
+     $              ccofld(jc,ig_number_field(jf)), 
+     $               acocoef(jc,ig_number_field(jf))
+ 330          CONTINUE
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD') THEN
+              WRITE(UNIT = nulou,FMT = 3027) 
+     $              cnaminp(ig_number_field(jf)), 
+     $              afldcobo(ig_number_field(jf))
+              WRITE(UNIT = nulou,FMT=3028) nbofld(ig_number_field(jf))
+              DO 340 jc = 1, nbofld(ig_number_field(jf))
+                WRITE (UNIT = nulou,FMT = 3030) 
+     $              cbofld(jc,ig_number_field(jf)), 
+     $                abocoef (jc,ig_number_field(jf))
+ 340          CONTINUE
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW') THEN
+              WRITE(UNIT = nulou,FMT = 3027) 
+     $              cnamout(ig_number_field(jf)), 
+     $              afldcobn(ig_number_field(jf))
+              WRITE(UNIT = nulou,FMT=3028) nbnfld(ig_number_field(jf))
+              DO 350 jc = 1, nbnfld(ig_number_field(jf))
+                WRITE (UNIT = nulou,FMT = 3030) 
+     $              cbnfld(jc,ig_number_field(jf)), 
+     $                abncoef (jc,ig_number_field(jf))
+ 350          CONTINUE
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SUBGRID') THEN
+              WRITE(UNIT = nulou,FMT = 3031) 
+     $              cgrdsub(ig_number_field(jf)), 
+     $              nlusub(ig_number_field(jf)),
+     $              nsubfl(ig_number_field(jf)), 
+     $              nsubvoi(ig_number_field(jf)), 
+     $              ctypsub(ig_number_field(jf))
+              IF (ctypsub(ig_number_field(jf)) .EQ. 'NONSOLAR') THEN 
+                  WRITE(UNIT = nulou,FMT = 3032) 
+     $                cdqdt(ig_number_field(jf)),
+     $                cfldcoa(ig_number_field(jf)), 
+     $                cfldfin(ig_number_field(jf))
+                ELSE IF (ctypsub(ig_number_field(jf)) .EQ. 'SOLAR') THEN
+                  WRITE(UNIT = nulou,FMT = 3033)
+     $                cfldfin(ig_number_field(jf)), 
+     $                  cfldcoa(ig_number_field(jf))
+              ENDIF
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKIN') THEN
+                WRITE(UNIT = nulou,FMT = 3034) 
+     $              ntinpflx(ig_number_field(jf))
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'CHECKOUT') THEN
+                WRITE(UNIT = nulou,FMT = 3035) 
+     $              ntoutflx(ig_number_field(jf)) 
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'GLORED') THEN
+              WRITE(UNIT = nulou,FMT = 3036) 
+     $              ntronca(ig_number_field(jf)) 
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'NOINTERP') THEN
+                WRITE(UNIT = nulou,FMT = 3037)
+            ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'LOCTRANS') THEN
+               WRITE(UNIT = nulou,FMT = 3047) cl_print_trans
+            ELSE 
+              WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+              WRITE (UNIT = nulou,FMT = *)
+     $            ' Type of analysis not implemented yet '
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' The analysis required in OASIS is :'
+              WRITE (UNIT = nulou,FMT = *) ' canal = ', 
+     $             canal(ja,ig_number_field(jf))
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' with ja = ', ja, ' jf = ', jf
+              WRITE (UNIT = nulou,FMT = *) ' '
+              CALL HALTE ('STOP in inipar')
+          ENDIF
+ 320    CONTINUE
+      ENDIF
+      ENDIF
+ 310  CONTINUE
+      ENDIF
+C
+C* Formats
+C
+ 3001 FORMAT(//,15X,'  FIELD NUMBER ',I3)
+ 3002 FORMAT(15X,'  ************  ')
+ 3003 FORMAT(/,10X,'  Field parameters ')
+ 3004 FORMAT(10X,'  ****************  ',/)
+ 3005 FORMAT(/,10X,'  Input field symbolic name       = ',A8,
+     $       /,10X,'  Output field symbolic name      = ',A8,
+     $       /,10X,'  Field long name                 = ',
+     $       /,18X,A53,
+     $       /,10X,'  Field exchange frequency        = ',I8,
+     $       /,10X,'  Model sequential index          = ',I2,
+     $       /,10X,'  Field Lag                       = ',I8,
+C     $       /,10X,'  Model delay flag                = ',I2,
+C     $       /,10X,'  Extra time step flag            = ',I2,
+     $       /,10X,'  Field I/O status                = ',A8,
+     $       /,10X,'  Number of basic operations      = ',I4,
+     $       /,10X,'  Parallel decomposition strategy = ',A8,/)
+ 3115 FORMAT(/,10X,'  Input field symbolic name       = ',A8,
+     $       /,10X,'  Output field symbolic name      = ',A8,
+     $       /,10X,'  Field long name                 = ',
+     $       /,18XA53,
+     $       /,10X,'  Field exchange frequency        = ',I8,
+     $       /,10X,'  Model sequential index          = ',I2,
+C     $       /,10X,'  Model delay flag                = ',I2,
+C     $       /,10X,'  Extra time step flag            = ',I2,
+     $       /,10X,'  Field I/O status                = ',A8,
+     $       /,10X,'  Number of basic operations      = ',I4,/)
+ 3116 FORMAT(/,10X,'  Input field symbolic name       = ',A8,
+     $       /,10X,'  Output field symbolic name      = ',A8,
+     $       /,10X,'  Field long name                 = ',
+     $       /,18XA53,
+     $       /,10X,'  Field exchange frequency        = ',I8,
+     $       /,10X,'  Local transformation            = ',A8,
+     $       /,10X,'  Model sequential index          = ',I2,
+     $       /,10X,'  Field Lag                       = ',I8, 
+     $       /,10X,'  Field I/O status                = ',A8,
+     $       /,10X,'  Number of basic operations      = ',I4,/)
+ 3117 FORMAT(/,10X,'  Restart file name               = ',A8,/)
+ 3118 FORMAT(/,10X,'  Input file name                 = ',A32,/)
+ 3121 FORMAT(/,10X,'  Input field symbolic name       = ',A8,
+     $       /,10X,'  Output field symbolic name      = ',A8,
+     $       /,10X,'  Field long name                 = ',
+     $       /,18XA53,
+     $       /,10X,'  Field exchange frequency        = ',I8,
+     $       /,10X,'  Local transformation            = ',A8,
+     $       /,10X,'  Field I/O status                = ',A8,
+     $       /,10X,'  Number of basic operations      = ',I4,/)
+ 3006 FORMAT(/,10X,'  Input file name                 = ',A8,
+     $       /,10X,'  Output file name                = ',A8,/)
+ 3007 FORMAT(
+     $       /,10X,'  Source grid periodicity type is      = ',A8,
+     $       /,10X,'  Number of overlapped grid points is  = ',I2,
+     $       /,10X,'  Target grid periodicity type is      = ',A8,
+     $       /,10X,'  Number of overlapped grid points is  = ',I2,/)
+ 3008 FORMAT(/,10X,'  Source longitude file string    = ',A8,
+     $       /,10X,'  Source latitude file string     = ',A8,
+     $       /,10X,'  Source mask file string         = ',A8,
+     $       /,10X,'  Source surface file string      = ',A8,
+     $       /,10X,'  Target longitude file string    = ',A8,
+     $       /,10X,'  Target latitude file string     = ',A8,
+     $       /,10X,'  Target mask file string         = ',A8,
+     $       /,10X,'  Target surface file string      = ',A8,/)
+ 3009 FORMAT(/,10X,'  ANALYSIS PARAMETERS ')
+ 3010 FORMAT(10X,'  ******************* ',/)
+ 3011 FORMAT(/,5X,'  ANALYSIS number ',I2,' is ',A8,
+     $       /,5X,'  ***************  ',/)
+ 3012 FORMAT(5X,' Value for masked points is        = ',E15.6)
+ 3013 FORMAT(5X,' Grid mapping file = ',A8,' linked to unit = ',I2,
+     $     /,5X,' Dataset identificator number      = ',I2,
+     $     /,5X,' Maximum number of neighbors is    = ',I4)
+ 3014 FORMAT(5X,' Source grid latitude order is    = ',A8)
+ 3015 FORMAT(5X,' Source grid longitude order is     = ',A8)
+ 3016 FORMAT(5X,' Target grid latitude order is    = ',A8)
+ 3017 FORMAT(5X,' Target grid longitude order is     = ',A8)
+ 3018 FORMAT(5X,' Extrapolation method is           = ',A8,
+     $     /,5X,' Number of neighbors used is       = ',I2)
+ 3019 FORMAT(5X,' Extrapolation file = ',A8,' linked to unit = ',I2,
+     $     /,5X,' Dataset identificator number      = ',I2)
+ 3020 FORMAT(5X,' Interpolation method is           = ',A8,
+     $     /,5X,' Source grid type is               = ',A8,
+     $     /,5X,' Field type is                     = ',A8)
+ 3021 FORMAT(5X,' Pointer for ANAIS storage is      = ',I2,
+     $     /,5X,' Maximum number of neighbors is    = ',I4,
+     $     /,5X,' Write/Read flag for weights is    = ',I2)
+ 3022 FORMAT(5X,' Variance multiplicator for ANAISG = ',E15.6)
+ 3023 FORMAT(5X,' Data to fill up field is in file  = ',A8,
+     $     /,5X,' Connected to logical unit number  = ',I2,
+     $     /,5X,' Filling method to blend field is  = ',A8)
+ 3024 FORMAT(5X,' Flag for coasts mismatch is       = ',I2, 
+     $     /,5X,' Name for flux correction field is = ',A8,
+     $     /,5X,' It is written on logical unit     = ',I2)
+ 3025 FORMAT(5X,' Conservation method for field is  = ',A8)
+ 3026 FORMAT(5X,' Half number of latitudes for gaussian grid is = ',I3,
+     $     /,5X,' Extrapolation flag is             = ',A8)
+ 3027 FORMAT(5X,' Field ',A8,' is multiplied by Cst = ',E15.6)
+ 3028 FORMAT(5X,' It is combined with N fields    N = ',I2)
+ 3029 FORMAT(5X,' Data file = ',A8,' linked to unit = ',I2)
+ 3030 FORMAT(5X,'   With field ',A8,'   coefficient = ',E15.6)
+ 3031 FORMAT(5X,' Subgrid data file = ',A8,' linked to unit = ',I2,
+     $     /,5X,' Dataset identificator number      = ',I2,
+     $     /,5X,' Maximum number of neighbors is    = ',I4,
+     $     /,5X,' Type of subgrid interpolation is  = ',A8)
+ 3032 FORMAT(5X,' Subgrid variability is restored with addition of',
+     $       /,5X,A8,' x (',A8,' - ',A8,')')
+ 3033 FORMAT(5X,' Subgrid variability is restored multiplying by',
+     $       /,5X,'( 1 - ',A8,') / ( 1 - ',A8,')')
+ 3034 FORMAT(5X,' Integral calculation flag is =', I2)
+ 3035 FORMAT(5X,' Integral calculation flag is =', I2)
+ 3036 FORMAT(5X,' Half number of latitudes for gaussian grid is = ',I3)
+ 3037 FORMAT(5X,' No interpolation for this field ')
+ 3038 FORMAT(5X,' Write/Read flag for weights is    = ',I2,
+     $     /,5X,' Dataset identificator number      = ',I2)
+C 3039 FORMAT(/,5X,' No delay flag in namcouple for field', I3,
+C     $     /,5X,' Default value DEL=0 will be used ')
+C 3040 FORMAT(/,5X,' No extra timestep flag in namcouple for field', I3,
+C     $     /,5X,' Default value XTS=0 will be used ') 
+ 3041 FORMAT(/,5X,' WARNING: Extra timestep flag > 1 for field', I3,
+     $     /,5X,' XTS=1 will be used instead') 
+ 3042 FORMAT(5X,' Value for exported masked points is = ',E15.6)
+ 3043 FORMAT(/,5X,'No lag in namcouple for the field', I3,
+     $    /,5X,' Default value LAG=0 will be used ')
+ 3044 FORMAT(/,5X,'The lag for the field ',I3,3X,'is : ',I8)
+ 3045 FORMAT(5X,' Remapping method is               = ',A8,
+     $     /,5X,' Field type is                     = ',A8,
+     $     /,5X,' Normalization option is           = ',A8,
+     $     /,5X,' Seach restriction type is         = ',A8,
+     $     /,5X,' Number of search bins is          = ',I4)
+ 3046 FORMAT(5X,' Order of remapping is             = ',A8)
+ 3047 FORMAT(5X,' Local transformation  = ',A8) 
+
+
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      WRITE(UNIT = nulou,FMT = *) ' '
+      WRITE(UNIT = nulou,FMT = *) 
+     $    '          ---------- End of routine inipar ---------'
+      CALL FLUSH (nulou)
+      RETURN
+C
+C* Error branch output
+C
+ 110  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $JOBNAME data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 130  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $NBMODEL data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 170  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $MACHINE data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+      
+ 181  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $CHATYPE data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP inipar')
+ 191  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $RUNTIME data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 193  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $INIDATE data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 195  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $SEQMODE data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 197  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $MODINFO data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 199  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $NLOGPRT found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 201  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $CALTYPE found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 210  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $FIELDS data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 230  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $STRING data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 231  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $             'NO index of sequential position and $SEQMODE > 1'
+      CALL halte('STOP in inipar.f')
+ 232  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $             'Index of sequential position greater than $SEQMODE'
+      CALL halte('STOP in inipar.f') 
+ 233  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $'Check the 2nd line for either the index of sequential position, 
+     $the delay flag, or the extra timestep flag.'
+      CALL halte('STOP in inipar.f')
+ 234  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $             'Index of sequential position equals 0'
+      WRITE (UNIT = nulou,FMT = *) 
+     $             '(Should be 1 -default value- IF $SEQMODE=1)'
+      CALL halte('STOP in inipar.f') 
+ 235  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $      'An input line with integral calculation flag' 
+      WRITE (UNIT = nulou,FMT = *) 
+     $      '("INT=0" or "INT=1")'
+      WRITE (UNIT = nulou,FMT = *) 
+     $      'is now required for analysis CHECKIN or CHECKOUT'
+      CALL halte('STOP in inipar.f') 
+ 236  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL prtout ('ERROR in namcouple for field', jf, 1)
+      WRITE (UNIT = nulou,FMT = *) 
+     $     'The coupling period must not be 0 !'
+      WRITE (UNIT = nulou,FMT = *) 
+     $     'If you do not want to exchange this field at all'
+       WRITE (UNIT = nulou,FMT = *) 
+     $     'give a coupling period longer than the total run time.'
+       CALL halte('STOP in inipar.f') 
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/inipar_alloc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/inipar_alloc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/inipar_alloc.F	(revision 1677)
@@ -0,0 +1,1130 @@
+      SUBROUTINE inipar_alloc
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *inipar_alloc*  - Get main run parameters to allocate arrays 
+C
+C     Purpose:
+C     -------
+C     Reads out run parameters.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *inipar_alloc*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     parse
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C     Version Programmer  Date      Description
+C     ------- ----------  ----      -----------  
+C       2.5   A. Caubel   02/04/02  created from inipar.f
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* -----------------Include files and use of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_parallel
+      USE mod_string
+      USE mod_analysis
+      USE mod_anais
+      USE mod_rainbow
+      USE mod_extrapol
+      USE mod_unitncdf
+      USE mod_experiment
+      USE mod_timestep
+      USE mod_coast
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_clim
+#endif
+      USE mod_calendar
+      USE mod_gauss
+      USE mod_hardware
+      USE mod_unit
+      USE mod_label
+      USE mod_printing 
+      INCLUDE 'netcdf.inc'  
+C
+C* ---------------------------- Local declarations --------------------
+C
+      CHARACTER*80 clline, clline_aux, clvari
+      CHARACTER*9 clword, clfield, clstring, clmod, clchan
+      CHARACTER*3 clind
+      CHARACTER*2 cldeb
+      CHARACTER*1 clequa
+      CHARACTER*8 clwork
+      CHARACTER*8 clstrg
+      CHARACTER*7 cl_bsend
+
+      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cl_aux
+      INTEGER (kind=ip_intwp_p) il_varid, il_len, il_err, il_maxanal 
+      INTEGER (kind=ip_intwp_p) nlonbf_notnc, nlatbf_notnc, 
+     $    nlonaf_notnc, nlataf_notnc
+      INTEGER (kind=ip_intwp_p) iind, il_redu, ib, il_aux, il_auxbf,
+     $     il_auxaf, istatus, il_id
+C
+C* ---------------------------- Poema verses --------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Get basic info for the simulation 
+C        ---------------------------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE inipar_alloc  -  Level 0'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           *********************    *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' Initialization of main run 
+     $    parameters'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' Reading input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+
+C
+C* Initialization
+      cchan = '    '
+      ig_direct_nfield = 0
+      ig_nfield = 0
+      lg_oasis_field = .true.
+      lg_vector = .FALSE.
+C* Initialize character keywords to locate appropriate input
+C
+      clfield  = ' $NFIELDS'
+      clchan   = ' $CHANNEL'
+      clstring = ' $STRINGS'
+      clmod    = ' $NBMODEL'
+C
+C* Get number of models involved in this simulation
+C
+      REWIND nulin
+ 100  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 110) clword
+      IF (clword .NE. clmod) GO TO 100
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $NBMODEL '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ELSE IF (ilen .GT. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) ' There are too many models '
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $NBMODEL variable spelling '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+      ELSE
+          READ (clvari,FMT = 1003) ig_nmodel
+      ENDIF
+C
+C* Print out the number of models
+C
+      CALL prtout
+     $    ('The number of models for this run is nmodel =', ig_nmodel,
+     $    1)
+C
+C --> Get the message passing technique we are using
+C
+      REWIND nulin
+ 120  CONTINUE
+      READ (UNIT = nulin,FMT = 1001,END = 130) clword
+      IF (clword .NE. clchan) GO TO 120
+      READ (UNIT = nulin,FMT = 1002) clline
+      CALL parse (clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $CHANNEL '
+          CALL HALTE('STOP in inipar')
+      ELSE IF (ilen .GT. 0 .AND. ilen .NE. 4) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Input variable length is incorrect'
+          WRITE (UNIT = nulou,FMT = *) ' ilen = ', ilen  
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Check $CHANNEL variable spelling '
+          CALL HALTE('STOP in inipar')
+      ELSE
+          cchan = clvari(1:4)
+C
+          IF (cchan .EQ. 'MPI1' .or. cchan .EQ. 'MPI2') THEN
+              CALL parse (clline, clvari, 2, jpeighty, ilen)
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+              IF (ilen .eq. 0) THEN
+                  lg_bsend = .true.
+              ELSE
+                  cl_bsend = clvari(1:7)
+                  IF (cl_bsend .eq. 'NOBSEND') THEN
+                      lg_bsend = .false.
+                  ELSE
+                      lg_bsend = .true.
+                  ENDIF
+              ENDIF
+#endif
+          ELSE IF(cchan .EQ. 'PVM3') THEN
+              WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' PVM3 no longer supported in Oasis 2.5'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            ' Please keep on using Oasis 2.4'
+              CALL HALTE('STOP in inipar')
+          ENDIF
+C
+C* Print out the message passing technique
+C
+          CALL prcout
+     $    (' The message passing used in OASIS is cchan =', cchan, 1)
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(A9)
+ 1002 FORMAT(A80)
+ 1003 FORMAT(I1)
+
+C
+C*    2. Get field information
+C        ---------------------
+C
+C* Read total number of fields exchanged
+C
+      REWIND nulin
+ 200  CONTINUE
+      READ (UNIT = nulin,FMT = 2001,END = 210) clword
+      IF (clword .NE. clfield) GO TO 200
+      READ (UNIT = nulin,FMT = 2002) clline
+      CALL parse(clline, clvari, 1, jpeighty, ilen)
+      IF (ilen .LE. 0) THEN
+          WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+          WRITE (UNIT = nulou,FMT = *) 
+     $        ' Nothing on input for $NFIELDS '
+          WRITE (UNIT = nulou,FMT = *) ' Default value will be used '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ELSE
+          READ (clvari,FMT = 2003) ig_total_nfield
+      ENDIF
+C
+C* Print out the total number of fields exchanged
+C
+      CALL prtout
+     $    ('The number of exchanged fields is nfield =', 
+     $     ig_total_nfield, 1)
+C
+C* Alloc field number array 
+C
+      ALLOCATE (ig_number_field(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $    ('Error: ig_number_field allocation of inipar_alloc',il_err,1)
+      ig_number_field(:)=0
+C
+C* Alloc field status array (logical indicating if the field goes through 
+C* Oasis or not)
+C
+      ALLOCATE (lg_state(ig_total_nfield), stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $    ('Error: lg_state allocation of inipar_alloc',il_err,1)
+      lg_state(:)=.false.
+C
+C* Alloc status of all the fields
+C 
+      ALLOCATE (ig_total_state(ig_total_nfield), stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $    ('Error: ig_total_state allocation of inipar_alloc',il_err,1)
+      ig_total_state(:)=0
+C
+C* Alloc input field name array 
+C
+      ALLOCATE (cg_output_field(ig_total_nfield), stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $    ('Error: cg_output_field allocation of inipar_alloc',il_err,1)
+      cg_output_field(:)=' ' 
+C
+C* Alloc number of analyses array 
+C
+      ALLOCATE (ig_total_ntrans(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $    ('Error: ig_total_ntrans"allocation of inipar_alloc',il_err,1)
+      ig_total_ntrans (:) = 0
+C 
+C* Alloc array of restart file names, input and output file names
+C
+      ALLOCATE (cg_restart_file(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $  ('Error: cg_restart_FILE allocation of inipar_alloc',il_err,1)
+      cg_restart_file(:)=' '
+      ALLOCATE (cg_input_file(ig_total_nfield), stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $ ('Error in "cg_input_file"allocation of inipar_alloc',il_err,1)
+      cg_input_file(:)=' '
+C 
+C* Alloc array of source and target locator prefix
+C
+      ALLOCATE (cga_locatorbf(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $  ('Error: cga_locatorbf allocation of inipar_alloc',il_err,1)
+      cga_locatorbf(:)=' '
+
+      ALLOCATE (cga_locatoraf(ig_total_nfield),stat=il_err)
+      IF (il_err.NE.0) CALL prtout 
+     $  ('Error: cga_locatoraf allocation of inipar_alloc',il_err,1)
+      cga_locatoraf(:)=' '  
+C
+C* Get the SSCS for all fields
+C
+      REWIND nulin
+ 220  CONTINUE
+      READ (UNIT = nulin,FMT = 2001,END = 230) clword
+      IF (clword .NE. clstring) GO TO 220
+C
+C* Loop on total number of fields (NoF)
+C
+      DO 240 jf = 1, ig_total_nfield
+C
+C* First line
+C
+        READ (UNIT = nulin,FMT = 2002) clline
+C* Get output field symbolic name
+        CALL parse(clline, clvari, 2, jpeighty, ilen)
+        cg_output_field(jf) = clvari
+C* Get total number of analysis
+        CALL parse(clline, clvari, 5, jpeighty, ilen)
+        READ (clvari,FMT = 2003) ig_total_ntrans(jf)
+C* Get field STATUS for OUTPUT fields
+        CALL parse(clline, clvari, 6, jpeighty, ilen)
+        IF (clvari(1:6) .eq. 'OUTPUT') THEN
+           ig_direct_nfield = ig_direct_nfield + 1
+           lg_state(jf) = .false.
+           ig_total_state(jf) = ip_output
+        ELSE
+C* Get field status (direct or through oasis) and the number  
+C* of direct and indirect fields if not PIPE nor NONE
+            IF (cchan .ne. 'PIPE' .and. cchan .ne. 'NONE') THEN
+                CALL parse(clline, clvari, 7, jpeighty, ilen)
+                IF (clvari(1:8).eq.'EXPORTED') THEN
+                    ig_nfield = ig_nfield + 1
+                    lg_state(jf) = .true.
+                    ig_number_field(jf) = ig_nfield
+                    ig_total_state(jf) = ip_exported
+C* Get restart file name
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+                    cg_restart_file(jf) = clvari
+                ELSEIF (clvari(1:7) .eq. 'IGNORED' ) THEN 
+                    ig_direct_nfield = ig_direct_nfield + 1
+                    lg_state(jf) = .false.
+                    ig_total_state(jf) = ip_ignored
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C* Get restart file name
+                    cg_restart_file(jf) = clvari
+                ELSEIF (clvari(1:6) .eq. 'EXPOUT') THEN
+                    ig_nfield = ig_nfield + 1
+                    lg_state(jf) = .true.
+                    ig_number_field(jf) = ig_nfield
+                    ig_total_state(jf) = ip_expout
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C* Get restart file name               
+                    cg_restart_file(jf) = clvari
+                ELSEIF (clvari(1:6) .eq. 'IGNOUT' ) THEN
+                    ig_direct_nfield = ig_direct_nfield + 1
+                    lg_state(jf) = .false.
+                    ig_total_state(jf) = ip_ignout
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C* Get restart file name 
+                    cg_restart_file(jf) = clvari
+                ELSEIF (clvari(1:9).eq. 'AUXILARY') THEN  
+                    ig_nfield = ig_nfield + 1
+                    lg_state(jf) = .true.
+                    ig_number_field(jf) = ig_nfield
+                    ig_total_state(jf) = ip_auxilary
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C* Get restart file name
+                    cg_restart_file(jf) = clvari
+                ELSEIF (clvari(1:5) .eq. 'INPUT') THEN
+                    ig_direct_nfield = ig_direct_nfield + 1
+                    lg_state(jf) = .false.
+                    ig_total_state(jf) = ip_input
+                    CALL parse(clline, clvari, 6, jpeighty, ilen)
+C* Get input file name
+                    cg_input_file(jf) = clvari
+                ENDIF
+            ELSE
+C*          Get field status if PIPE or NONE
+              CALL parse(clline, clvari, 8, jpeighty, ilen)
+              IF (clvari .ne. 'EXPORTED' .and. clvari .ne. 'AUXILARY') 
+     $             THEN
+                 CALL prtout 
+     $                ('Error in namcouple for status of field',jf,1)
+                 WRITE (UNIT = nulou,FMT = *) 
+     $                '==> Must be EXPORTED or AUXILARY'
+                 IF (clvari(1:7) .eq. 'IGNORED') 
+     $                WRITE (UNIT = nulou,FMT = *)
+     $           'Direct communication is only for CLIM/MPI1 or MPI2'
+                 WRITE (UNIT = nulou,FMT = *) 
+     $               'Maybe you forgot the output FILE name which'
+                 WRITE (UNIT = nulou,FMT = *) 
+     $               'is mandatory for PIPE or NONE techniques'
+                 CALL HALTE('STOP in inipar') 
+              ELSE IF (clvari .eq. 'EXPORTED') THEN
+                 ig_nfield = ig_nfield + 1
+                 lg_state(jf) = .true.
+                 ig_number_field(jf) = ig_nfield
+                 ig_total_state(jf) = ip_exported
+C* Get restart file name
+                 CALL parse(clline, clvari, 6, jpeighty, ilen)
+                 cg_restart_file(jf) = clvari
+              ELSE IF (clvari .eq. 'AUXILARY') THEN
+                 ig_nfield = ig_nfield + 1
+                 lg_state(jf) = .true.
+                 ig_number_field(jf) = ig_nfield
+                 ig_total_state(jf) = ip_auxilary
+C* Get restart file name
+                 CALL parse(clline, clvari, 6, jpeighty, ilen)
+                 cg_restart_file(jf) = clvari
+              ENDIF
+          ENDIF
+      ENDIF
+      IF (lg_state(jf)) THEN
+           IF (ig_total_ntrans(jf) .eq. 0) THEN
+              WRITE (UNIT = nulou,FMT = *)
+     $             'If there is no analysis for the field',jf,
+     $             'then the status must not be "EXPORTED"' 
+              WRITE (UNIT = nulou,FMT = *)' "AUXILARY" or "EXPOUT" '
+              CALL HALTE('STOP in inipar_alloc') 
+           ENDIF
+           READ (UNIT = nulin,FMT = 2002) clline
+           CALL skip(clline, jpeighty)
+           READ (UNIT = nulin,FMT = 2002) clline
+           CALL skip(clline, jpeighty)
+           READ (UNIT = nulin,FMT = 2002)clline_aux
+           DO ja=1,ig_total_ntrans(jf)
+              CALL parse(clline_aux, clvari, ja, jpeighty, ilen)
+              IF (clvari.eq.'CORRECT'.or.clvari.eq.'BLASOLD'.
+     $             or.clvari.eq.'BLASNEW') THEN
+                 READ (UNIT = nulin,FMT = 2002) clline
+                 CALL parse(clline, clvari, 2, jpeighty, ilen)
+                 READ(clvari,FMT = 2003) il_aux
+                 DO ib = 1, il_aux
+                    READ (UNIT = nulin,FMT = 2002) clline
+                    CALL skip(clline, jpeighty)
+                  ENDDO
+              ELSE IF (clvari.eq.'NOINTERP') THEN
+                  CONTINUE
+              ELSE
+                  READ (UNIT = nulin,FMT = 2002) clline
+                  CALL skip(clline, jpeighty)
+              ENDIF
+            ENDDO
+        ELSE
+           IF (ig_total_state(jf) .ne. ip_input) THEN
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+           ENDIF
+           IF (ig_total_state(jf) .ne. ip_input .and. 
+     $          ig_total_ntrans(jf) .gt. 0 ) THEN
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL parse(clline, clvari, 1, jpeighty, ilen)
+              IF (clvari(1:8) .ne. 'LOCTRANS') THEN
+                 WRITE (UNIT = nulou,FMT = *)
+     $              'You want a transformation which is not available !'
+                 WRITE (UNIT = nulou,FMT = *)
+     $              'Only local transformations are available for '
+                 WRITE (UNIT = nulou,FMT = *)
+     $              'fields exchanged directly or output fields '
+                 CALL HALTE('STOP in inipar_alloc') 
+              ENDIF
+              DO ja=1,ig_total_ntrans(jf)
+                 READ (UNIT = nulin,FMT = 2002) clline
+                 CALL skip(clline, jpeighty)
+              ENDDO
+           ENDIF 
+        ENDIF          
+        
+ 240    CONTINUE
+        IF (ig_nfield.eq.0) THEN
+            lg_oasis_field = .false.
+            WRITE (nulou,*)'==> All the fields are exchanged directly'
+        ENDIF
+        
+C
+C* Number of different restart files
+C
+        allocate (cl_aux(ig_total_nfield))
+        cl_aux(:)=' '
+        DO jf = 1,ig_total_nfield
+          IF (jf.eq.1) THEN
+              cl_aux(1) = cg_restart_file(1)
+              il_aux = 1
+          ELSEIF (jf.gt.1) THEN
+              IF (ALL(cl_aux.ne.cg_restart_file(jf))) THEN
+                  il_aux = il_aux + 1  
+                  cl_aux(il_aux) = cg_restart_file(jf)
+              ENDIF
+          ENDIF
+        ENDDO
+        deallocate(cl_aux)
+        ig_nbr_rstfile = il_aux
+
+        IF (lg_oasis_field) THEN
+C 
+C*      Alloc array needed for INTERP and initialize them
+C
+            ALLOCATE (cintmet(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: cintmet allocation of inipar_alloc',il_err,1)
+            ALLOCATE (naismfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: naismfl allocation of inipar_alloc',il_err,1)
+            ALLOCATE (naismvoi(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: naismvoi allocation of inipar_alloc',il_err,1)
+            ALLOCATE (naisgfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: naisgfl allocation of inipar_alloc',il_err,1)
+            ALLOCATE (naisgvoi(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: naisgvoi allocation of inipar_alloc',il_err,1)
+            cintmet(:)=' '
+            naismfl(:) = 1
+            naismvoi(:) = 1
+            naisgfl(:) = 1
+            naisgvoi(:) = 1
+C     
+C*          Alloc arrays needed for EXTRAP and initialize them
+C     
+            ALLOCATE (cextmet(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: cextmet allocation of inipar_alloc',il_err,1)
+            ALLOCATE (nninnfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout
+     $          ('Error: nninnfl allocation of inipar_alloc',il_err,1)
+            ALLOCATE (nninnflg(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout
+     $          ('Error: nninnflg allocation of inipar_alloc',il_err,1)
+            ALLOCATE (neighbor(ig_nfield), stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: neighbor allocation of inipar_alloc',il_err,1)
+            ALLOCATE (nextfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nextfl allocation of inipar_alloc',il_err,1)
+            cextmet(:)=' '
+            nninnfl(:) = 1
+            nninnflg(:) = 1
+            neighbor(:) = 1
+            nextfl(:) = 1
+C     
+C*          Alloc arrays needed for BLAS... analyses and initialize them 
+C     
+            ALLOCATE (nbofld(ig_nfield), stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nbofld allocation of inipar_alloc',il_err,1)
+            ALLOCATE (nbnfld(ig_nfield), stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nbnfld allocation of inipar_alloc',il_err,1)
+            nbofld(:) = 1
+            nbnfld(:) = 1
+C     
+C*          Alloc arrays needed for MOZAIC and initialize them
+C     
+            ALLOCATE (nmapvoi(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nmapvoi allocation of  inipar_alloc',il_err,1)
+            ALLOCATE (nmapfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nmapfl allocation of inipar_alloc',il_err,1)
+            nmapvoi(:) = 1
+            nmapfl(:) = 1
+C     
+C*          Alloc arrays needed for SUBGRID and initialize them
+C     
+            ALLOCATE (nsubfl(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nsubfl allocation of inipar_alloc',il_err,1)
+            ALLOCATE (nsubvoi(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nsubvoi allocation of inipar_alloc',il_err,1)
+            nsubfl(:) = 1
+            nsubvoi(:) = 1
+C     
+C*          Alloc arrays needed for GLORED and REDGLO and initialize them 
+C     
+            ALLOCATE (ntronca(ig_nfield), stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: ntronca allocation of inipar_alloc',il_err,1)
+            ntronca(:) = 0
+
+C     
+C*          Alloc array needed for analyses parameters 
+C     
+            ALLOCATE (cficbf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: cficbf allocation of inipar_alloc',il_err,1)
+            cficbf(:)=' '
+            ALLOCATE (cficaf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: cficaf allocation of inipar_alloc',il_err,1)
+            cficaf(:)=' '
+C     
+C*         Alloc arrays needed for grid dimensions of direct fields and 
+C*         indirect fields
+C     
+            ALLOCATE (nlonbf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nlonbf allocation of inipar_alloc',il_err,1)
+            nlonbf(:)=0
+            ALLOCATE (nlatbf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nlatbf allocation of inipar_alloc',il_err,1)
+            nlatbf(:)=0
+            ALLOCATE (nlonaf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nlonaf allocation of inipar_alloc',il_err,1)
+            nlonaf(:)=0
+            ALLOCATE (nlataf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: nlataf allocation of inipar_alloc',il_err,1)
+            nlataf(:)=0
+C     
+C*         Alloc arrays needed for grid number associated to each field
+C 
+            ALLOCATE (ig_grid_nbrbf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $      ('Error: ig_grid_nbrbf allocation of inipar_alloc',il_err,1)
+            ig_grid_nbrbf(:)=0
+            ALLOCATE (ig_grid_nbraf(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $      ('Error: ig_grid_nbraf allocation of inipar_alloc',il_err,1)
+            ig_grid_nbraf(:)=0
+            
+C     
+C*          Alloc number of analyses array 
+C     
+            ALLOCATE (ig_ntrans(ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: ig_ntrans allocation of inipar_alloc',il_err,1)
+            ig_ntrans(:)=0
+            DO ib = 1, ig_total_nfield
+              IF (lg_state(ib))
+     $            ig_ntrans(ig_number_field(ib))=ig_total_ntrans(ib)
+            ENDDO
+C     
+C*          Maximum number of analyses 
+C     
+            il_maxanal = imaxim(ig_ntrans,ig_nfield)
+C     
+C*          Alloc array of restart file names
+C     
+            ALLOCATE (cficinp(ig_nfield), stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: cficinp allocation of inipar_alloc',il_err,1)
+            cficinp(:)=' '
+            DO ib = 1, ig_total_nfield
+              IF (lg_state(ib)) 
+     $            cficinp(ig_number_field(ib))=cg_restart_file(ib)
+            END DO
+            istatus=NF_OPEN(cg_restart_file(1), NF_NOWRITE, il_id)
+            IF (istatus .ne. NF_NOERR) THEN
+                lncdfrst = .false.
+            ELSE
+                lncdfrst = .true.
+            ENDIF
+            WRITE(nulou, *) 'lncdfrst =', lncdfrst
+C     
+C*          Alloc array needed to get analysis names
+C 
+            ALLOCATE (canal(il_maxanal,ig_nfield),stat=il_err)
+            IF (il_err.NE.0) CALL prtout 
+     $          ('Error: canal allocation of inipar_alloc',il_err,1)
+            canal(:,:)=' '
+        ENDIF
+C
+C*      Get analysis parameters 
+C
+        REWIND nulin
+ 221    CONTINUE
+        READ (UNIT = nulin,FMT = 2001,END = 230) clword
+        IF (clword .NE. clstring) GO TO 221
+C
+C*      Loop on total number of fields (NoF)
+C      
+        DO 250 jf=1,ig_total_nfield
+C
+C*        Initialization
+C
+          nlonbf_notnc = 0
+          nlatbf_notnc = 0
+          nlonaf_notnc = 0
+          nlataf_notnc = 0
+C
+C*        Skip first line read before
+C
+          READ (UNIT = nulin,FMT = 2002) clline
+          CALL skip(clline, jpeighty)
+C     
+C* Second line
+C
+C* In the indirect case, reading of second, third, fourth line and analyses 
+C* lines
+C
+          IF (ig_total_state(jf) .ne. ip_input) THEN
+              READ (UNIT = nulin,FMT = 2002) clline
+C*            First determine what information is on the line
+              CALL parse(clline, clvari, 3, jpeighty, ilen)
+              IF (ilen .lt. 0) THEN
+C*                  
+C*                IF only two words on the line, then they are the locator 
+C*                prefixes and the grids file must be in NetCDF format       
+                  CALL parse(clline, clvari, 1, jpeighty, ilen)
+                  IF (lg_state(jf)) 
+     $                cficbf(ig_number_field(jf)) = clvari
+                  cga_locatorbf(jf) = clvari(1:4)
+                  CALL parse(clline, clvari, 2, jpeighty, ilen)
+                  IF (lg_state(jf))
+     $                cficaf(ig_number_field(jf)) = clvari
+                  cga_locatoraf(jf) = clvari(1:4)
+                  lncdfgrd = .true.
+              ELSE 
+                  READ(clvari,FMT = 2010) clind, clequa, iind
+                  IF (clind .EQ. 'SEQ' .or. clind .EQ. 'DEL' .or. 
+     $                clind .eq. 'XTS' .or. clind .eq. 'LAG' .and.
+     $                clequa .EQ. '=') THEN
+                      
+C*                    If 3rd word is an index, then first two words are 
+C*                    locator prefixes and grids file must be NetCDF format
+                      CALL parse(clline, clvari, 1, jpeighty, ilen) 
+                      IF (lg_state(jf)) 
+     $                    cficbf(ig_number_field(jf)) = clvari 
+                      cga_locatorbf(jf) = clvari(1:4)
+                      CALL parse(clline, clvari, 2, jpeighty, ilen)
+                      IF (lg_state(jf)) 
+     $                    cficaf(ig_number_field(jf)) = clvari
+                      cga_locatoraf(jf) = clvari(1:4)
+                      lncdfgrd = .true.
+                  ELSE
+C*              If not, the first 4 words are grid dimensions and next
+C*              2 words are locator prefixes, and grids file may be or
+C*              not in NetCDF format 
+                      CALL parse(clline, clvari, 1, jpeighty, ilen)
+C*                    Get number of longitudes for initial field
+                      READ(clvari,FMT = 2004) nlonbf_notnc
+                      CALL parse(clline, clvari, 2, jpeighty, ilen)
+C*                    Get number of latitudes for initial field
+                      READ(clvari,FMT = 2004) nlatbf_notnc
+                      CALL parse(clline, clvari, 3, jpeighty, ilen)
+C*                    Get number of longitudes for final field
+                      READ(clvari,FMT = 2004) nlonaf_notnc
+                      CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                    Get number of latitudes for final field
+                      READ(clvari,FMT = 2004) nlataf_notnc
+                      CALL parse(clline, clvari, 5, jpeighty, ilen)
+C*                    Get root name grid-related files (initial field)
+                      IF (lg_state(jf)) 
+     $                    cficbf(ig_number_field(jf)) = clvari
+                      cga_locatorbf(jf) = clvari(1:4)
+                      CALL parse(clline, clvari, 6, jpeighty, ilen)
+C*                    Get root name for grid-related files (final field)
+                      IF (lg_state(jf)) 
+     $                    cficaf(ig_number_field(jf)) = clvari
+                      cga_locatoraf(jf) = clvari(1:4)
+                      nlonbf(ig_number_field(jf)) = nlonbf_notnc
+                      nlatbf(ig_number_field(jf)) = nlatbf_notnc
+                      nlonaf(ig_number_field(jf)) = nlonaf_notnc
+                      nlataf(ig_number_field(jf)) = nlataf_notnc
+C
+                   ENDIF
+               ENDIF
+C
+C*           Read the P 2 P 0 line for exported, expout or auxilary
+C
+             IF (lg_state(jf)) THEN
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+             ENDIF
+C     
+C*            Read next line of strings
+C             --->>> Stuff related to field transformation
+C
+             IF (ig_total_ntrans(jf) .gt. 0) then 
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+              DO 260 ja = 1, ig_total_ntrans(jf)
+                CALL parse(clline, clvari, ja, jpeighty, ilen)
+C*              Get the whole set of analysis to be performed
+                IF (lg_state(jf)) 
+     $              canal(ja,ig_number_field(jf)) = clvari
+ 260          CONTINUE
+C     
+C*            Now read specifics for each transformation
+C
+           DO 270 ja = 1, ig_total_ntrans(jf)
+C     
+C*            Read next line unless if analysis is NOINTERP (no input)
+C
+             IF (lg_state(jf)) THEN
+C            For EXPORTED, AUXILARY, or EXPOUT:
+              IF(canal(ja,ig_number_field(jf)) .NE. 'NOINTERP') THEN 
+                  READ (UNIT = nulin,FMT = 2002) clline
+                  CALL skip(clline, jpeighty)
+              ENDIF
+              IF (canal(ja,ig_number_field(jf)) .EQ. 'MOZAIC') THEN
+                  CALL parse(clline, clvari, 3, jpeighty, ilen)
+C*                Get dataset number
+                  READ(clvari,FMT = 2005) nmapfl(ig_number_field(jf))
+                  CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                Get max nbr of neighbors for the grids associated to current field
+                  READ(clvari,FMT = 2003) nmapvoi(ig_number_field(jf))
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'EXTRAP')THEN
+                  CALL parse(clline, clvari, 1, jpeighty, ilen)
+C*                Get extrapolation method
+                  cextmet(ig_number_field(jf)) = clvari
+C*                If choice is NINENN, read one more data
+                  IF (cextmet(ig_number_field(jf)) .EQ. 'NINENN') THEN
+                      CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                    Get NINENN dataset identificator
+                      READ(clvari,FMT = 2005)
+     $                    nninnfl(ig_number_field(jf))
+                      IF (nninnfl(ig_number_field(jf)) .EQ. 0) THEN
+                          WRITE(UNIT = nulou,FMT = *)'  ***WARNING***'
+                          WRITE(UNIT = nulou,FMT = *) 
+     $   ' **WARNING** The EXTRAP/NINENN dataset id cannot be 0' 
+                          CALL HALTE('STOP in inipar')
+                      ENDIF
+C*                    If choice is WEIGHT, read more data
+                  ELSE IF (cextmet(ig_number_field(jf)) .EQ. 'WEIGHT') 
+     $                    THEN
+                      CALL parse(clline, clvari, 2, jpeighty, ilen)
+C  Get number of neighbors used in extrapolation
+C  If extrapolation method is NINENN, next variable is the MINIMUM
+C  number of neighbors required (among the 8 closest) to perform
+C  the extrapolation (cannot be greater than 4 for convergence). 
+C  In case it is WEIGHT, it is the MAXIMUM number
+C  of neighbors required by the extrapolation operation.
+C     
+                      READ(clvari,FMT = 2003) 
+     $                    neighbor(ig_number_field(jf))
+                      CALL parse(clline, clvari, 5, jpeighty, ilen)
+C*                    Get dataset number
+                      READ(clvari,FMT = 2005) 
+     $                    nextfl(ig_number_field(jf))
+                  ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'INTERP')THEN
+                  CALL parse(clline, clvari, 1, jpeighty, ilen)
+C*                Get interpolation method
+                  cintmet(ig_number_field(jf)) = clvari
+C*                If interpolation uses ANAIS(G-M), read in more data
+                  IF (cintmet(ig_number_field(jf)) .EQ. 'SURFMESH') THEN
+                      CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                    Get Anaism dataset identificator
+                      READ(clvari,FMT = 2005)
+     $                    naismfl(ig_number_field(jf))
+                      CALL parse(clline, clvari, 5, jpeighty, ilen)
+C*                    Get max number of neighbors for the grids related to current field
+                      READ(clvari,FMT = 2003) 
+     $                    naismvoi(ig_number_field(jf))
+                  ENDIF 
+                  IF (cintmet(ig_number_field(jf)) .EQ. 'GAUSSIAN') THEN
+                      CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                    Get Anaisg dataset identificator
+                      READ(clvari,FMT = 2005)
+     $                    naisgfl(ig_number_field(jf))
+                      CALL parse(clline, clvari, 5, jpeighty, ilen)
+C*                    Get max number of neighbors for the grids related to current field
+                      READ(clvari,FMT = 2003) 
+     $                    naisgvoi(ig_number_field(jf))
+                  ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SCRIPR')THEN
+C* Get field type (scalar/vector)
+              CALL parse(clline, clvari, 3, jpeighty, ilen)
+              READ(clvari,FMT = 2009) clstrg
+              IF(clstrg .EQ. 'VECTOR_I' .OR. clstrg .EQ. 'VECTOR_J')THEN
+                  lg_vector  = .TRUE.
+              ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'REDGLO')THEN
+                  CALL parse(clline, clvari, 1, jpeighty, ilen)
+C*                Get half the nbr of lats for reduced<->global gaussian grid switch
+                  READ(clvari,FMT = 2008) cldeb, 
+     $                ntronca(ig_number_field(jf))
+                  IF (cldeb .NE. 'NO') THEN
+                      CALL prcout
+     $                    ('ERROR in namcouple for analysis', 
+     $                    canal(ja,ig_number_field(jf)), 1) 
+                      WRITE (UNIT = nulou,FMT = *) 
+     $             'Since version 2.3, the information on the reduced'
+                      WRITE (UNIT = nulou,FMT = *) 
+     $             'grid in namcouple has to be NOxx WHERE xx is half'
+                      WRITE (UNIT = nulou,FMT = *) 
+     $             'the number of latitude lines.'
+                      CALL HALTE ('STOP in inipar')
+                  ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'GLORED')THEN
+                  CALL parse(clline, clvari, 1, jpeighty, ilen)
+C*                Get gaussian troncature for reduced <-> global gaussian grid switch
+                  READ(clvari,FMT = 2008) cldeb, 
+     $                ntronca(ig_number_field(jf))
+                  IF (cldeb .NE. 'NO') THEN
+                      CALL prcout
+     $                    ('ERROR in namcouple for analysis', 
+     $                    canal(ja,ig_number_field(jf)), 1) 
+                      WRITE (UNIT = nulou,FMT = *) 
+     $              'Since version 2.3, the information on the reduced'
+                      WRITE (UNIT = nulou,FMT = *) 
+     $              'grid in namcouple has to be NOxx WHERE xx is half'
+                      WRITE (UNIT = nulou,FMT = *) 
+     $              'the number of latitude lines.'
+                      CALL HALTE ('STOP in inipar')
+                  ENDIF
+                  CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                Get NINENN dataset identificator
+                  READ(clvari,FMT = 2005) nninnflg(ig_number_field(jf))
+                  IF (nninnflg(ig_number_field(jf)) .EQ. 0) THEN
+                     WRITE(UNIT = nulou,FMT = *) 
+     $ '**WARNING** The EXTRAP/NINENN dataset identificator in GLORED' 
+                     WRITE(UNIT = nulou,FMT = *) 
+     $                    'cannot be 0'
+                     CALL HALTE('STOP in inipar')
+                  ENDIF
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASOLD') 
+     $                THEN
+                  CALL parse(clline, clvari, 2, jpeighty, ilen)
+C*                Get number of additional fields in linear formula
+                  READ(clvari,FMT = 2003) nbofld (ig_number_field(jf))
+                  DO ib = 1,nbofld (ig_number_field(jf))
+                    READ (UNIT = nulin,FMT = 2002) clline
+                    CALL skip(clline, jpeighty)
+                  ENDDO
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'BLASNEW') 
+     $                THEN
+                  CALL parse(clline, clvari, 2, jpeighty, ilen)
+C*                Get number of additional fields in linear formula
+                  READ(clvari,FMT = 2003) nbnfld (ig_number_field(jf))
+                  DO ib = 1,nbnfld (ig_number_field(jf))
+                    READ (UNIT = nulin,FMT = 2002) clline
+                    CALL skip(clline, jpeighty)
+                  ENDDO
+C*                Get fields to restore subgrid variability 
+              ELSE IF (canal(ja,ig_number_field(jf)) .EQ. 'SUBGRID') 
+     $                THEN
+                  CALL parse(clline, clvari, 3, jpeighty, ilen)
+C*                Get dataset number
+                  READ(clvari,FMT = 2005) nsubfl(ig_number_field(jf))
+                  CALL parse(clline, clvari, 4, jpeighty, ilen)
+C*                Get max number of neighbors for the grids related to current field
+                  READ(clvari,FMT = 2003) nsubvoi(ig_number_field(jf))
+              ENDIF
+             ELSE
+C             For IGNORED, IGNOUT and OUTPUT, only one line for LOCTRANS
+              READ (UNIT = nulin,FMT = 2002) clline
+              CALL skip(clline, jpeighty)
+             ENDIF             
+ 270        CONTINUE
+        ENDIF
+      ENDIF
+C
+C*      End of loop on NoF
+C     
+ 250  CONTINUE
+C
+      IF (lg_oasis_field) THEN 
+C     
+C*       Search maximum number of fields to be combined in the BLASxxx analyses
+C     
+          ig_maxcomb = imaxim(nbofld,ig_nfield)
+          IF (imaxim(nbnfld,ig_nfield).gt.ig_maxcomb)
+     $        ig_maxcomb = imaxim(nbnfld,ig_nfield)
+C     
+C*          Search maximum number of underlying neighbors for SURFMESH interpolation
+C     
+          ig_maxwoa = imaxim(naismvoi,ig_nfield)
+          WRITE(nulou,*)
+     $        'Max number of underlying neighbors for SURFMESH : ', 
+     $        ig_maxwoa
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of neighbors for GAUSSIAN interpolation
+C     
+          ig_maxnoa = imaxim(naisgvoi,ig_nfield)
+          WRITE(nulou,*)
+     $        'Max number of neighbors for GAUSSIAN interp : ',
+     $        ig_maxnoa
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of underlying neighbors for MOZAIC interpolation
+C     
+          ig_maxmoa = imaxim(nmapvoi,ig_nfield)
+          WRITE(nulou,*)
+     $    'Maximum number of underlying neighbors for MOZAIC interp: ',
+     $        ig_maxmoa
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of overlaying neighbors for SUBGRID interpolation
+C     
+          ig_maxsoa = imaxim(nsubvoi,ig_nfield)
+          WRITE(nulou,*)
+     $    'Maximum number of overlaying neighbors for SUBGRID interp :',
+     $        ig_maxsoa
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different SURFMESH interpolations
+C     
+          ig_maxnfm = imaxim(naismfl,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of different SURFMESH interpolations : ',
+     $        ig_maxnfm
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different GAUSSIAN interpolations
+C     
+          ig_maxnfg = imaxim(naisgfl,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of different GAUSSIAN interpolations : ',
+     $        ig_maxnfg
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different MOZAIC interpolations
+C     
+          ig_maxnfp = imaxim(nmapfl,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of different MOZAIC interpolations : ',
+     $        ig_maxnfp
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different SUBGRID interpolations
+C     
+          ig_maxnfs = imaxim(nsubfl,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of different SUBGRID interpolations : ',
+     $        ig_maxnfs
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different NINENN extrapolations
+C     
+          ig_maxnfn = imaxim(nninnfl,ig_nfield)
+          IF (imaxim(nninnflg,ig_nfield).gt.ig_maxnfn)
+     $        ig_maxnfn = imaxim(nninnflg,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of different NINENN extrapolations : ',
+     $        ig_maxnfn
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of neighbors for extrapolation  
+C     
+          ig_maxext = imaxim(neighbor,ig_nfield)
+          WRITE(nulou,*)
+     $        'Maximum number of neighbors for extrapolation : ',
+     $        ig_maxext
+          WRITE(nulou,*)' '
+C     
+C*          Search maximum number of different extrapolation
+C     
+          ig_maxnbn = imaxim(nextfl,ig_nfield)
+C  
+      ENDIF
+C*    Formats
+C
+ 2001 FORMAT(A9)
+ 2002 FORMAT(A80)
+ 2003 FORMAT(I4)
+ 2004 FORMAT(I8)
+ 2005 FORMAT(I2)
+ 2008 FORMAT(A2,I4)
+ 2009 FORMAT(A8)
+ 2010 FORMAT(A3,A1,I2)
+C
+C*    3. End of routine
+C        --------------
+C
+      WRITE(UNIT = nulou,FMT = *) ' '
+      WRITE(UNIT = nulou,FMT = *) 
+     $      '          ---------- End of routine inipar_alloc ---------'
+      CALL FLUSH (nulou)
+      RETURN
+C
+C*    Error branch output
+C
+ 110  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *)
+     $    ' No active $NBMODEL data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar_alloc')
+ 130  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $MACHINE data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar')
+ 210  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $FIELDS data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar_alloc')
+ 230  CONTINUE
+      WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' No active $STRING data found in input file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' We STOP!!! Check the file namcouple'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      CALL HALTE ('STOP in inipar_alloc')
+
+      END
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/initim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/initim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/initim.f	(revision 1677)
@@ -0,0 +1,171 @@
+      SUBROUTINE initim
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *initim*  - Initialize time
+C
+C     Purpose:
+C     -------
+C     Initialize date at run starting date and find coupler timestep
+C     value
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *initim*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0beta   L. Terray      95/08/30  modified : new structure
+C       2.0       L. Terray      96/02/01  modified : get final iteration
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      01/12/10  Explicit intialization of nddeb
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_parameter
+      USE mod_string
+      USE mod_timestep 
+      USE mod_unit
+      USE mod_calendar
+      USE mod_printing
+C
+C* ---------------------------- Local functions -------------------------
+C
+C* - Time functions
+C    Date is under form: ccaammdd
+C            ndd   --->>> extract dd from ccaammdd
+C            nmm   --->>> extract mm from ccaammdd
+C            nccaa --->>> extract ccaa from ccaammdd
+C            ncth  --->>> turn seconds into hours
+C
+      ndd(kidat) = MOD(kidat,100)
+      nmm(kidat) = MOD((kidat - ndd(kidat))/100,100)
+      nccaa(kidat) = kidat / 10000
+      ncth(ksec) = ksec / 3600
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations
+C         ---------------
+C     
+         IF (nlogprt .GE. 1) THEN
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           ROUTINE initim  -  Level 0'
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '           **************     *******'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' Determine time iteration parameters '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           ' and initialize simulation date '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+C     
+C* First, get initial date of this run
+C
+         ig_date(:) = 0
+         njini = ndd(ndate)
+         ig_date(3) = njini
+         nmini = nmm(ndate)
+         ig_date(2) = nmini
+         naini = nccaa(ndate)
+         ig_date(1) = naini
+C     
+C* Print initial date of this run
+C
+         WRITE (UNIT = nulou,FMT = 1001) njini,  nmini, naini
+         WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Following lines are called only if one field (at least) goes through Oasis
+C
+         IF (lg_oasis_field) THEN
+C     
+C* Get time iteration parameters
+C     
+C* Get minimum exchange frequency
+C     
+            ifrqmin = iminim (nfexch, ig_nfield)
+C     
+C* Get greatest common divisor for all frequencies
+C     
+            nstep = idivmax (nfexch, ig_nfield, ifrqmin)
+C     
+C* Get total number of iterations
+C     
+            niter = ntime / nstep
+C     
+C* Get final iteration number
+C     
+            nitfn = niter - 1
+C     
+         IF (nlogprt .GE. 1) THEN
+C*    Print number of iterations and timestep
+C     
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '      Number of iterations = ', niter
+            WRITE (UNIT = nulou,FMT = *) '     ====================   '
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '      Value of timestep = ', nstep
+            WRITE (UNIT = nulou,FMT = *) '     =================   '
+            WRITE (UNIT = nulou,FMT = *) ' '
+         ENDIF
+C     
+C* Get beginning date of the whole coupled simulation
+C     
+         nddeb = 0
+         njdeb = ndd(nddeb)
+         nmdeb = nmm(nddeb)
+         nadeb = nccaa(nddeb)
+      ENDIF
+C     
+C* Formats
+C     
+ 1001    FORMAT(5X,'  Run initial date : ',I2,' - ',I2,' - ',I4,
+     $        /,5X,'  ================ ')
+C     
+C     
+C*    2. End of routine
+C     --------------
+C     
+         IF (nlogprt .GE. 1) THEN 
+            WRITE (UNIT = nulou,FMT = *) ' '
+            WRITE (UNIT = nulou,FMT = *) 
+     $           '          --------- End of routine initim ---------'
+            CALL FLUSH (nulou)
+         ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/interp.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/interp.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/interp.f	(revision 1677)
@@ -0,0 +1,417 @@
+      SUBROUTINE interp (kindex, kfield)
+C****
+C               *****************************
+C       
+C        * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *interp* - Control routine for interpolation
+C
+C
+C     Purpose:
+C     -------
+C     Monitor the field interpolation and auxilary analysis
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *interp (kindex, kfield)*
+C
+C     Input:
+C     -----
+C                kindex : current active fields index array
+C                kfield : current active fields total number
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     fiasco, blasold, filling, mozaic
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0beta   L. Terray      95/09/01  created
+C       2.0       L. Terray      96/02/01  modified: mozaic interpolation
+C       2.1       L. Terray      96/08/05  modified: Add new arrays for
+C                                          mapping data(weight, adresses)
+C                                          addition of no interpolation
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  changed: periodicity variables
+C       2.5       Gayler/Declat  01/11/09  scrip remapping
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ----------------Include files and USE of modules ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_extrapol
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_anais
+      USE mod_rainbow
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: zbocoef
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iaddr, 
+     $    isize, iflag
+      CHARACTER(len=8),DIMENSION(:), ALLOCATABLE :: clbofld 
+      CHARACTER*8 clintmet, clgrdtyp, clfldtyp, clfilfic, clfilmet
+      CHARACTER*8 clfic, clstrg, clname
+      CHARACTER*8 clsper, cltper
+      LOGICAL llchk
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization and allocation of local arrays
+C        ---------------------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE interp  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Monitor field interpolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+      ALLOCATE (zbocoef(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "zbocoef" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (iaddr(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "iaddr" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (isize(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "isize" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (iflag(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "iflag" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (clbofld(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "clbofld" allocation of 
+     $    cookart ',il_err,1)
+      zbocoef(:)=0
+      iaddr(:)=0
+      isize(:)=0
+      iflag(:)=0
+      clbofld(:)=' '
+C
+C
+C*    2. Do the job
+C        ----------
+C
+!$omp parallel do default (shared)
+!$omp+ private (ja,jf,jj,ji,jd,jb,jc,jk,jl)
+!$omp+ private (ifield,clsper,clname,ilataf,ilonaf)
+!$omp+ private (itper,isper,cltper)
+!$omp+ private (ipdeb,ilatbf,ilonbf,isiznew)
+!$omp+ private (ibofld,zfldcobo,iadrnew,iadrnew_grid)
+!$omp+ private (iadrold,iadrold_grid,isizold)
+!$omp+ private (isize,iflag)
+!$omp+ private (ipointer,iaddr,isiztot,clfic)
+!$omp+ private (clfilmet,iunit,ivoisin,clstrg)
+!$omp+ private (iloc,clintmet,clgrdtyp,clfldtyp)
+!$omp+ private (clfilfic,llchk)
+
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+        ifield = kindex(jf)
+        iadrold = nadrold(ifield)
+        iadrold_grid = nadrold_grid(ifield)
+        isizold = nsizold(ifield)
+        iadrnew = nadrnew(ifield)
+        iadrnew_grid = nadrnew_grid(ifield)
+        isiznew = nsiznew(ifield)
+        ilonbf = nlonbf(ifield)
+        ilatbf = nlatbf(ifield)
+        ilonaf = nlonaf(ifield)
+        ilataf = nlataf(ifield)
+        clname = cnaminp(ifield)
+        clsper = csper(ifield)
+        cltper = ctper(ifield)
+        isper = nosper(ifield)
+        itper = notper(ifield)
+C
+C* Print field name
+C
+        IF (nlogprt .GE. 1) THEN
+            CALL prcout('Treatment of field : ', clname, 2)
+        ENDIF
+C
+C* - Do interpolation
+C
+        DO 220 ja = 1, ig_ntrans(ifield)
+          IF (canal(ja,ifield) .EQ. 'INTERP') THEN
+C
+C* --->>> Interp
+C
+C* Assign local variables
+              clintmet = cintmet(ifield)
+              clgrdtyp = cgrdtyp(ifield)
+              clfldtyp = cfldtyp(ifield)
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+!$omp critical
+              CALL fiasco
+C* Data about fields, grids, masks and surfaces
+     $             (fldnew(iadrnew),
+     $             xgrnew(iadrnew_grid), ygrnew(iadrnew_grid), 
+     $             surnew(iadrnew_grid),
+     $             msknew(iadrnew_grid), ilonaf, ilataf, cltper, itper,
+     $             fldold(iadrold),
+     $             xgrold(iadrold_grid), ygrold(iadrold_grid), 
+     $             surold(iadrold_grid),
+     $             mskold(iadrold_grid), ilonbf, ilatbf, clsper, isper,
+C* Work arrays for the different interpolators
+     $             work(1), 
+     $             work(1+ilonaf), 
+     $             work(1+ilonaf+ilataf),
+     $             work(1+ilonaf+ilataf+isizold),
+     $             work(1+ilonaf+ilataf+isizold+isiznew),
+     $             work(1+ilonaf+ilataf+2*isizold+isiznew),
+C* Define field number and type, grid and interpolation 
+     $             ifield, clintmet, clgrdtyp, clfldtyp)
+!$omp end critical
+C
+C* --->>> Nointerp
+C
+          ELSE IF (canal(ja,ifield) .EQ. 'NOINTERP') THEN
+C
+C* output field is equal to input field
+C
+C* First, check dimension
+C
+                llchk = ilataf .EQ. ilatbf .AND.
+     $              ilonaf-itper .EQ. ilonbf-isper
+                IF (.NOT. llchk) CALL prcout('WARNING: size mismatch
+     $              in NOINTERP between old and new field ',clname,2)
+                IF (.NOT. llchk) CALL HALTE('STOP in interp')
+C* Do the assign
+                DO 230 jj = 1, ilatbf
+                  DO 233 ji = 1, ilonbf-isper
+                    jk = (jj-1)*ilonaf+ji
+                    jl = (jj-1)*ilonbf+ji
+                    fldnew(iadrnew - 1 + jk) = fldold(iadrold - 1 + jl)
+ 233              CONTINUE 
+                  DO 236 ji = 1, itper
+                    jk = (jj-1)*ilonaf+ilonaf-itper+ji
+                    jl = (jj-1)*ilonbf+ji
+                    fldnew(iadrnew - 1 + jk) = fldold(iadrold - 1 + jl)
+ 236              CONTINUE 
+ 230            CONTINUE 
+C
+C* --->>> Mozaic
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'MOZAIC') THEN
+C
+C* assign local variables and get pointer for mapping interpolation
+C
+                clfic = cgrdmap(ifield)
+                iunit = nlumap(ifield)
+                iloc = nmapfl(ifield)
+                ipdeb = (nmapfl(ifield)-1)*ig_maxmoa*ig_maxgrd+1
+                ivoisin = nmapvoi(ifield)
+                clstrg = cficbf(ifield)//cficaf(ifield)
+                CALL mozaic (fldnew(iadrnew), isiznew,
+     $                       fldold(iadrold), isizold,
+     $                       clfic, iunit, clstrg, iloc,
+     $                       amapp(ipdeb), nmapp(ipdeb), 
+     $                       ivoisin, lmapp(ifield))
+C* --->>> SCRIP remapping
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'SCRIPR') THEN
+C
+C* perform the scrip remapping
+C
+                clgrdtyp = cgrdtyp(ifield)
+C
+C* Vector case
+C
+                IF (cfldtype(ifield) .eq. 'VECTOR_I' .or.
+     $              cfldtype(ifield) .eq. 'VECTOR_J') THEN
+
+                    ifield_assoc = ig_assoc_input_field(ifield)
+                    iadrold_assoc = nadrold(ifield_assoc)
+                    iadrold_assoc_grid = nadrold_grid(ifield_assoc)
+                    iadrnew_assoc = nadrnew(ifield_assoc)
+                    isizold_assoc = nsizold(ifield_assoc)
+                    isiznew_assoc = nsiznew(ifield_assoc)
+                    ilonbf_assoc = nlonbf(ifield_assoc)
+                    ilatbf_assoc = nlatbf(ifield_assoc)
+
+                    CALL scriprmp_vector (
+     $               fldnew(iadrnew), fldold(iadrold), isizold, isiznew, 
+     $               mskold(iadrold_grid), msknew(iadrnew_grid),
+     $               xgrold(iadrold_grid), ygrold(iadrold_grid),
+     $               ilonbf, ilatbf, 
+     $               xgrnew(iadrnew_grid), ygrnew(iadrnew_grid), ilonaf,
+     $               ilataf, 
+     $               cmap_method(ifield), clgrdtyp, nosper(ifield),
+     $               cficbf(ifield), cficaf(ifield), cnorm_opt(ifield), 
+     $               corder(ifield), crsttype(ifield), nbins(ifield),
+     $               lextrapdone(ifield), varmul(ifield), 
+     $               nscripvoi(ifield),
+     $               fldold(iadrold_assoc),cfldtype(ifield),
+     $               xgrold(iadrold_assoc_grid),
+     $               ygrold(iadrold_assoc_grid),
+     $               mskold(iadrold_assoc_grid),cficbf(ifield_assoc),
+     $               cficaf(ifield_assoc),lrotate(ifield),
+     $               fldnew(iadrnew_assoc),isizold_assoc,isiznew_assoc,
+     $               ilonbf_assoc, ilatbf_assoc)
+
+                 ELSE
+C
+C* Scalar case
+C
+
+                    CALL scriprmp (
+     $                   fldnew(iadrnew), fldold(iadrold), isizold, 
+     $                   isiznew, 
+     $                   mskold(iadrold_grid), msknew(iadrnew_grid),
+     $                   xgrold(iadrold_grid), ygrold(iadrold_grid), 
+     $                   ilonbf, ilatbf, 
+     $                   xgrnew(iadrnew_grid), ygrnew(iadrnew_grid), 
+     $                   ilonaf, ilataf, 
+     $                   cmap_method(ifield), clgrdtyp, nosper(ifield),
+     $                   cficbf(ifield), cficaf(ifield), 
+     $                   cnorm_opt(ifield), 
+     $                   corder(ifield), crsttype(ifield), 
+     $                   nbins(ifield),
+     $                   lextrapdone(ifield), varmul(ifield), 
+     $                   nscripvoi(ifield)) 
+                 END IF
+C
+C* --->>> Blasold
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'BLASOLD') THEN
+C
+C* Assign local variables
+C
+              zfldcobo = afldcobo(ifield)
+              ibofld = nbofld(ifield)
+              DO 240 jc = 1, ibofld
+                clbofld(jc) = cbofld(jc,ifield)
+                zbocoef(jc) = abocoef(jc,ifield)
+ 240          CONTINUE
+C
+C* Get the additional fields (pointers and sizes)
+C
+              CALL szero( work, ig_work)
+              DO 250 jc = 1, ibofld
+                IF (clbofld(jc) .EQ. 'CONSTANT') THEN
+                    isize(jc) = isizold
+                  ELSE 
+                    DO 260 jb = 1, ig_nfield
+C
+C* Check field names input list
+C
+                      IF (clbofld(jc) .EQ. cnaminp(jb)) THEN
+                          iflag(jc) = jb
+                      ENDIF 
+ 260                CONTINUE
+                    ipointer  = nadrold(iflag(jc))
+                    isize(jc) = nsizold(iflag(jc))
+                ENDIF 
+                IF (jc .EQ. 1) THEN
+                    iaddr(jc) = 1
+                  ELSE
+                    iaddr(jc) = 1 + isize(jc-1)
+                ENDIF
+C
+C* Assign values to temporary array work
+C
+                IF (clbofld(jc) .EQ. 'CONSTANT') THEN
+                    DO 270 jd = 1, isize(jc)
+                      work(iaddr(jc)+jd-1) = 1.0
+ 270                CONTINUE 
+                  ELSE 
+                    DO 280 jd = 1, isize(jc)
+                      work(iaddr(jc)+jd-1) = fldold(ipointer+jd-1)
+ 280                CONTINUE 
+                ENDIF 
+ 250          CONTINUE
+C
+C* Get total size for array work ( sum of additional fields sizes)
+C 
+              isiztot = iaddr(ibofld) + isize(ibofld) - 1
+              CALL blasold (fldold(iadrold), isizold, ifield,
+     $                      zfldcobo, ibofld, iaddr, isize,
+     $                      zbocoef, isiztot, work)
+C
+C* --->>> Filling
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'FILLING') THEN
+C
+C* Assign local variables
+C
+              clfilfic = cfilfic(ifield)
+              iunit = nlufil(ifield)
+              clfilmet = cfilmet(ifield)
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+C
+C* Address of overlapping grids array used in Anaism 
+C
+              ipointer = (naismfl(ifield)-1)*ig_maxgrd + 1
+              CALL filling (fldnew(iadrnew), work(1), work(isiznew+1),
+     $                      work(2*isiznew+1),
+     $                      xgrnew(iadrnew_grid), ygrnew(iadrnew_grid),
+     $                      ilonaf, ilataf, 
+     $                      msknew(iadrnew_grid), nmesh(ipointer), iunit,
+     $                      clfilfic, clfilmet)
+            ELSE
+              CONTINUE
+          END IF
+ 220    CONTINUE
+ 210  CONTINUE 
+C
+C
+C*    3. Deallocation and end of routine
+C        -------------------------------
+C
+      DEALLOCATE(zbocoef)
+      DEALLOCATE(iaddr)
+      DEALLOCATE(isize)
+      DEALLOCATE(iflag)
+      DEALLOCATE(clbofld)
+
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine interp ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/invert.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/invert.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/invert.f	(revision 1677)
@@ -0,0 +1,132 @@
+      SUBROUTINE invert (pfild ,kxlon ,kylat, cdxord, cdyord)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *invert* - Ordering routine
+C
+C     Purpose:
+C     -------
+C     Reorder field with increasing latitude from south to north
+C     and longitude going east from Greenwhich.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *invert (pfild ,kxlon ,kylat, cdxord, cdyord)*
+C
+C     Input:
+C     -----
+C                pfild  : field to be reordered (real 2D)
+C                kxlon  : number of longitudes
+C                kylat  : number of latitudes
+C                cdxord : latitude ordering
+C                cdyord : longitude ordering
+C
+C     Output:
+C     ------
+C                pfild  : field reordered (real 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/10/10  modified; new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(kxlon,kylat)
+      CHARACTER*8 cdxord, cdyord
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      LOGICAL llxord, llyord
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE invert  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Reorder field South ---> North '
+          WRITE (UNIT = nulou,FMT = *) ' and from Greenwhich ---> East '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      llxord = cdxord .EQ. 'SUDNOR'
+      llyord = cdyord .EQ. 'WSTEST'
+C
+C
+C*    2. Reorder field 
+C        -------------
+C* South-North buisness
+C
+      IF ( .NOT. llxord) THEN
+          ijmed = kylat/2 
+          DO 210 jj = 1, ijmed
+            DO 220 ji = 1, kxlon
+              zfild = pfild(ji,kylat + 1 - jj)
+              pfild(ji,kylat + 1 - jj) = pfild(ji,jj)
+              pfild(ji,jj) = zfild
+ 220        CONTINUE
+ 210      CONTINUE
+      ENDIF 
+C
+C* East-West one
+C
+      IF ( .NOT. llyord) THEN
+          iimed = kxlon/2 
+          DO 230 jj = 1, kylat
+            DO 240 ji = 1, iimed
+              zfild = pfild(kxlon + 1 - ji,jj)
+              pfild(kxlon + 1 - ji,jj) = pfild(ji,jj)
+              pfild(ji,jj) = zfild
+ 240        CONTINUE
+ 230      CONTINUE
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine invert ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/isumi.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/isumi.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/isumi.f	(revision 1677)
@@ -0,0 +1,73 @@
+      FUNCTION isumi (ka, kna)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *isumi*  - Arithmetic function
+C
+C     Purpose:
+C     -------
+C     Sum of the elements of an integer array
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *isumi (ka, kna)*
+C
+C     Input:
+C     -----
+C                ka     : array to be summed (integer 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) isumi, ka(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Perform the sum
+C        ---------------
+C
+      itemp = 0
+      DO 110 ji = 1, kna
+        itemp = itemp + ka(ji)
+ 110  CONTINUE
+      isumi = itemp
+C
+C* End of function
+C
+      RETURN 
+      END
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/izero.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/izero.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/izero.f	(revision 1677)
@@ -0,0 +1,77 @@
+      SUBROUTINE izero (ka, kna)
+C****
+C               ********************************
+C               * OASIS SUBROUTINE  -  LEVEL T *
+C               * ----------------     ------- *
+C               ********************************
+C
+C**** *izero*  - Utility routine
+C
+C     Purpose:
+C     -------
+C     Zero integer array from element 1 to element kna
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *izero (ka, kna)*
+C
+C     Input:
+C     -----
+C                ka     : array to be zeroed (integer 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C                ka     : array filled up with zeros (integer 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) ka(kna)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) inzero
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Zero the array 
+C        ---------------
+C
+      inzero = 0
+      DO 110 ja = 1, kna
+        ka(ja) = inzero
+  110 CONTINUE
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/jcoor.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/jcoor.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/jcoor.f	(revision 1677)
@@ -0,0 +1,70 @@
+      FUNCTION jcoor (kind, kimax)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *jcoor*  - Search function
+C
+C     Purpose:
+C     -------
+C     Given an index value, kind, for a 2D array which has kimax rows, 
+C     this function returns the column number
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *jcoor (kind, kimax)*
+C
+C     Input:
+C     -----
+C                kind   : index (integer)
+C                kimax  : number of rows (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.1       R. Sutton      95/11/25  Created
+C       2.0       L. Terray      95/12/26  Modified: to suit OASIS 2.0
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) jcoor
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the column number 
+C        ----------------------
+C
+      jcoor = 1 + (kind-1) / kimax
+C
+C* End of function
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locread.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locread.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locread.f	(revision 1677)
@@ -0,0 +1,118 @@
+      SUBROUTINE locread (cdfldn, pfield, kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locread*  - Read binary field on unit knulre
+C
+C     Purpose:
+C     -------
+C     Find string cdfldn on unit knulre and read array pfield
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locread (cdfldn, pfield, kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be read 
+C                knulre : logical unit to be read 
+C
+C     Output:
+C     ------
+C                pfield : field array (real 1D)
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfield(kdimax)
+      CHARACTER*8 cdfldn
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clecfl
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locread  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Read binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+      REWIND knulre
+ 200  CONTINUE
+C* Find string
+      READ (UNIT = knulre, ERR = 200, END = 210) clecfl
+      IF (clecfl .NE. cdfldn) GO TO  200
+C* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) pfield
+C* Reading done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in reading
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locread ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locreadh.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locreadh.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locreadh.f	(revision 1677)
@@ -0,0 +1,124 @@
+      SUBROUTINE locreadh (cdfldn, cdjob, ktime, pfield, 
+     $                     kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locreadh*  - Read header and binary field on unit knulre 
+C
+C     Purpose:
+C     -------
+C     Find string cdfldn on unit knulre and read header and array pfield
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locreadh (cdfldn, cdjob, ktime, pfield, 
+C                          kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be read 
+C                knulre : logical unit to be read 
+C
+C     Output:
+C     ------
+C                cdjob  : experiment name
+C                ktime  : header array (integer 1D)
+C                pfield : field array (real 1D)
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       L. Terray      97/12/14  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfield(kdimax)
+      INTEGER (kind=ip_intwp_p) ktime(3)
+      CHARACTER*8 cdfldn
+      CHARACTER*3 cdjob
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clecfl
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locreadh  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Read binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+      REWIND knulre
+ 200  CONTINUE
+C* Find string
+      READ (UNIT = knulre, ERR = 200, END = 210) clecfl, cdjob, ktime
+      IF (clecfl .NE. cdfldn) GO TO  200
+C* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) pfield
+C* Reading done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in reading
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locreadh ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locrint.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locrint.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locrint.f	(revision 1677)
@@ -0,0 +1,118 @@
+      SUBROUTINE locrint (cdfldn, kfield, kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locrint*  - Read binary integer field on unit knulre
+C
+C     Purpose:
+C     -------
+C     Find string cdfldn on unit knulre and read integer array pfield
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locrint (cdfldn, kfield, kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be read 
+C                knulre : logical unit to be read 
+C
+C     Output:
+C     ------
+C                kfield : field array (integer 1D)
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kfield(kdimax)
+      CHARACTER*8 cdfldn
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clecfl
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locrint  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Read binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+      REWIND knulre
+ 200  CONTINUE
+C* Find string
+      READ (UNIT = knulre, ERR = 200, END = 210) clecfl
+      IF (clecfl .NE. cdfldn) GO TO  200
+C* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) kfield
+C* Reading done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in reading
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locrint ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locwrint.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locwrint.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locwrint.f	(revision 1677)
@@ -0,0 +1,111 @@
+      SUBROUTINE locwrint (cdfldn, kfield, kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locwrint*  - Write binary integer field on unit knulre
+C
+C     Purpose:
+C     -------
+C     Write string cdfldn and integer array kfield on unit knulre
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locwrint (cdfldn, kfield, kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be written 
+C                knulre : logical unit to be written
+C                kfield : field array (integer 1D) 
+C
+C     Output:
+C     ------
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p)  kfield(kdimax)
+      CHARACTER*8 cdfldn
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locwrint  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Write binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+C* Write string
+      WRITE (UNIT = knulre, ERR = 210) cdfldn
+C* Write associated field
+      WRITE (UNIT = knulre, ERR = 210) kfield
+C* Writing done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in Writing
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locwrint ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locwrite.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locwrite.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locwrite.f	(revision 1677)
@@ -0,0 +1,111 @@
+      SUBROUTINE locwrite (cdfldn, pfield, kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locwrite*  - Write binary field on unit knulre
+C
+C     Purpose:
+C     -------
+C     Write string cdfldn and array pfield on unit knulre
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locwrite (cdfldn, pfield, kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be written 
+C                knulre : logical unit to be written
+C                pfield : field array (real 1D) 
+C
+C     Output:
+C     ------
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfield(kdimax)
+      CHARACTER*8 cdfldn
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locwrite  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Write binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+C* Write string
+      WRITE (UNIT = knulre, ERR = 210) cdfldn
+C* Write associated field
+      WRITE (UNIT = knulre, ERR = 210) pfield
+C* Writing done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in Writing
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locwrite ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/locwrith.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/locwrith.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/locwrith.f	(revision 1677)
@@ -0,0 +1,117 @@
+      SUBROUTINE locwrith (cdfldn, cdjob, ktime, pfield, 
+     $                     kdimax, knulre, kflgre)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locwrith*  - Write binary field and header on unit knulre
+C
+C     Purpose:
+C     -------
+C     Write string cdfldn, header and array pfield on unit knulre
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locwrith (cdfldn, pfield, cdjob, ktime,
+C                          kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                cdjob  : experiment name
+C                ktime  : header array (integer 1D)
+C                kdimax : dimension of field to be written 
+C                knulre : logical unit to be written
+C                pfield : field array (real 1D) 
+C
+C     Output:
+C     ------
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.2       L. Terray      97/12/14  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfield(kdimax)
+      INTEGER (kind=ip_intwp_p) ktime(3)
+      CHARACTER*8 cdfldn
+      CHARACTER*3 cdjob
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE locwrith  -  Level 0'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ****************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = 1001) knulre
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Write binary file connected to unit = ',I3)
+C
+C     2. Write header and field to file
+C        ------------------------------
+C
+C* Write string and header
+      WRITE (UNIT = knulre, ERR = 210) cdfldn, cdjob, ktime
+C* Write associated field
+      WRITE (UNIT = knulre, ERR = 210) pfield
+C* Writing done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in Writing
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine locwrith ---------'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/masq.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/masq.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/masq.f	(revision 1677)
@@ -0,0 +1,106 @@
+      SUBROUTINE masq (pfild, ksize, pmask, kmask)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *masq* - Mask routine
+C
+C     Purpose:
+C     -------
+C     Mask field with chosen value
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *masq (pfild, ksize, pmask, kmask)*
+C
+C     Input:
+C     -----
+C                pfild : field to be masked (real 1D)
+C                ksize : array size
+C                pmask : mask value given from input
+C                kmask : mask array : 0 ---> ocean , 1 ---> land (integer 1D)
+C
+C     Output:
+C     ------
+C                pfild : field masked (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     cvmgp
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0beta   L. Terray      95/10/01  modified: new structure
+C       2.0       L. Terray      96/02/01  modified: suppression of file
+C                                                    doctor.h
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      2K/09/04  Remove cmach and cvmgp
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(ksize)
+      INTEGER (kind=ip_intwp_p) kmask(ksize)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE masq  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Mask field with input value'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C
+C*    2. Mask field with value
+C        ---------------------
+C
+      DO 220 jk = 1, ksize
+        ztest = float(1 - kmask(jk)) -.5
+        IF (ztest .LT. 0.) pfild(jk) = pmask
+ 220  CONTINUE 
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine masq ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_anais.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_anais.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_anais.F90	(revision 1677)
@@ -0,0 +1,70 @@
+MODULE mod_anais
+!
+! -- anais.h   01-11-95   Version 2.0   Author: Laurent Terray
+!    *******             
+!              31-08-96   Version 2.1 : add new fields for anais package
+!
+!              18-03-02   Version 2.5 : changed in module
+!@
+!@  Contents : variables and arrays related to the ANAIS interpolator
+!@  --------
+!@
+!@ Anaism --->>>
+!@
+!@ -- nmesh : number of ocean gcm-1 squares overlapped by a given gcm-2 
+!@            square (1D)
+!@
+!@ -- amint : weight for each gcm-1 mesh proportional to overlapped area (1D)
+!@
+!@ -- nmint : neighbors adress on gcm-1 grid for a given gcm-2 grid point (1D)
+!@
+!@ -- naismfl : flag to identify different ANAISM parameter sets (1D)
+!@
+!@ -- naismvoi : maximum number of overlapped neighbors (1D)
+!@
+!@ -- niwtm : flag to read/write ANAISM parameters (1D)
+!@
+!@ -- cwanaism : file name for ANAISM parameter file  
+!@
+!@ Anaisg --->>>
+!@
+!@ -- agint : weight for each gcm-1 grid point with gaussian distribution (1D)
+!@
+!@ -- ngint : neighbors adress on gcm-1 grid for a given gcm-2 grid point (1D)
+!@
+!@ -- varmul : variance multiplicator
+!@
+!@ -- naisgfl : flag to identify different ANAISG parameter sets (1D)
+!@
+!@ -- naisgvoi :  maximum number of used neighbors (1D)
+!@
+!@ -- niwtg : flag to read/write ANAISG parameters (1D)
+!@
+!@ -- cwanaisg : file name for ANAISG parameter file
+!@
+!@ Common --->>>
+!@
+!@ -- linit : I/O initialization flag for each field
+!@
+!@ -- cnaisout : ANAIS output file name
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+!
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ngint,nmint,nmesh
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naismfl, naisgfl
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: naismvoi, naisgvoi
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtm, niwtg
+!
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: agint, amint, varmul
+!
+  LOGICAL, DIMENSION(:), ALLOCATABLE :: linit
+!
+  CHARACTER(len=8), PARAMETER :: cwanaisg = 'gweights' 
+  CHARACTER(len=8), PARAMETER :: cwanaism = 'mweights'
+  CHARACTER(len=8), PARAMETER :: cnaisout = 'anaisout'
+!
+!   -------------------------------------------------------------------
+END MODULE mod_anais
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_analysis.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_analysis.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_analysis.F90	(revision 1677)
@@ -0,0 +1,240 @@
+MODULE mod_analysis
+!
+! -- analysis.h   18-08-95   Version 2.0beta   Author: Laurent Terray
+!    **********   01-02-96   Version 2.0 : addition of cdqdt,cgrdmap,nlumap
+!                                          and nmapfl
+!                 05-08-96   Version 2.1 : addition of nlusub, cgrdsub 
+!                                          ctypsub and nsubfl (subgrid)
+!                 29-08-96   Version 2.1 : new input for subgrid, mozaic
+!                                          and anais, maximum number of
+!                                          neighbors. New input for redglo
+!                 14-04-99   Version 2.3 : new input for extrap called by
+!                                          glored. Change periodicity 
+!                                          variables.
+!                 05-09-00   Version 2.5 : integral flags for check[in-out]
+!                 18-03-02   Version 2.5 : changed in module
+!                 27-06-02   Version 2.5 : scrip added
+!@
+!@  Contents : variables related to the set of analysis for each field
+!@  --------
+!@
+!@ Mask :
+!@
+!@ -- amskval : mask value for the imported field
+!@
+!@ MaskP :
+!@
+!@ -- amskvalnew : mask value for the exported field
+!@
+!@
+!@ Mozaic :
+!@
+!@ -- cgrdmap : file name for grid mapping used in mozaic (1D)
+!@
+!@ -- nlumap  : logical units associated to previous files (1D)
+!@
+!@ -- nmapfl  : mapping dataset identificator number (1D)
+!@
+!@ -- nmapvoi : maximum number of neighbors (1D)
+!@
+!@ Invert :
+!@
+!@ -- cxordbf : field ordering (longitude) before interpolation (1D)
+!@
+!@ -- cyordbf : field ordering (latitude) before interpolation (1D)
+!@
+!@ Reverse :
+!@
+!@ -- cxordaf : field ordering (longitude) after interpolation (1D)
+!@
+!@ -- cyordaf : field ordering (latitude) after interpolation (1D)
+!@
+!@ Extrap :
+!@
+!@ -- cextmet : extrapolation method (1D)
+!@
+!@ -- neighbor : number of neighbors used in extrapolation (1D)
+!@
+!@ -- neighborg : number of neighbors used in extrapolation when extrap
+!@                is called by GLORED (1D)
+!@
+!@ -- cgrdext : file names for data used in extrapolation WEIGHT (1D)
+!@
+!@ -- nluext  : logical units associated to previous files (1D)
+!@
+!@ -- nextfl  : extrapolation dataset identificator number (1D)
+!@
+!@ Interp :
+!@
+!@ -- cintmet : interpolation method (1D)
+!@
+!@ -- cgrdtyp : source grid type (1D)
+!@
+!@ -- csper   : source grid periodicity type (Periodic, Regional, Overlap)
+!@
+!@ -- ctper   : target grid periodicity type (Periodic, Regional, Overlap)
+!@
+!@ -- cfldtyp : field type (scalar or vector) (1D)
+!@
+!@ Scrip :
+!@
+!@ -- cmap_method : scrip remapping method ('CONSERV', 'BILINEAR', 'BICUBIC',
+!@                                          'GAUSWGT'or 'DISTWGT')
+!@ -- cfldtype    : field type ('SCALAR' or 'VECTOR_I' or `VECTOR_J')
+!@
+!@ -- cnorm_opt   : normalization option ('FRACAREA', 'DESTAREA' or 'NONE')
+!@
+!@ -- crsttype    : restriction type for SCRIP search ('LATITUDE', 'LATLON',
+!@                                                     or 'REDUCED')
+!@
+!@ -- nbins       : number of search bins
+!@
+!@ -- corder      : remapping order ('FIRST' or 'SECOND')
+!@
+!@ --  nscripvoi  : number of neighbour for 'GAUSWGT'or 'DISTWGT'
+!@
+!@ -- ig_assoc_input_field : number id of the associated field for vector case
+!@
+!@ -- cg_assoc_input_field : name of the associated field for vector case
+!@
+!@ -- lrotate :  logical for the rotation to cartesian referential in vector case
+!@
+!@ Filling :
+!@
+!@ -- cfilfic : file name for climatological field to complete model field (1D)
+!@
+!@ -- nlufil  : logical units connected to previous files (1D)
+!@
+!@ -- cficmet : filling method (1D)
+!@
+!@ -- cfldcor : field name for flux correction term due to SST filling
+!@
+!@ -- nlucor  : logical unit used to write flux correction term
+!@
+!@ !onserv :
+!@
+!@ -- cconmet : conservation method (1D)
+!@
+!@ Glored, redglo :
+!@
+!@ -- ntronca : gaussian troncature for reduced <-> global gaussian grid (1D)
+!@
+!@ -- cmskrd : extrapolation flag to handle processing reduced grid values (1D)
+!@
+!@ Correct :
+!@
+!@ -- afldcoef : main field multiplicative coefficient (1D)
+!@
+!@ -- ncofld : number of additional fields in correction formula (1D)
+!@
+!@ -- ccofic : file names for additional data files (2D)
+!@
+!@ -- nludat : logical units associated to previous files (2D)
+!@
+!@ -- ccofld : symbolic names for additional fields (2D)
+!@
+!@ -- acocoef : multiplicative coefficients for additional fields (2D)
+!@
+!@ Blasold :
+!@
+!@ -- afldcobo : main field multiplicative coefficient (1D)
+!@
+!@ -- nbofld : number of additional fields in linear combination formula (1D)
+!@
+!@ -- cbofld : symbolic names for additional fields (2D)
+!@
+!@ -- abocoef : multiplicative coefficients for additional fields (2D)
+!@
+!@ Blasnew :
+!@
+!@ -- afldcobn : main field multiplicative coefficient (1D)
+!@
+!@ -- nbnfld : number of additional fields in linear combination formula (1D)
+!@
+!@ -- cbnfld : symbolic names for additional fields (2D)
+!@
+!@ -- abncoef : multiplicative coefficients for additional fields (2D)
+!@
+!@ Subgrid :
+!@
+!@ -- cgrdsub : file name for subgrid data used in subgrid (1D)
+!@
+!@ -- nlusub  : logical units associated to previous files (1D)
+!@
+!@ -- ctypsub : type of subgrid interpolation (solar or non solar) (1D)
+!@
+!@ -- nsubfl  : subgrid dataset identificator number (1D)
+!@
+!@ -- nsubvoi : maximum number of neighbors (1D)
+!@
+!@ -- cfldcoa : coarse grid field name (1D)
+!@
+!@ -- cfldfin : fine grid field name (1D)
+!@
+!@ -- cdqdt   : first order taylor coefficient (1D)
+!@
+!@ Checkin :
+!@
+!@ -- ntinpflx : input field integral flag
+!@
+!@ Checkout :
+!@
+!@ -- ntoutflx : output field integral flag
+!@
+!@ Checkin, Checkout, Conserv, Gaussian
+!@
+!@ -- lsurf: Logical indicating if grid surface information has to be given 
+!@            in auxiliary file areas or areas.nc 
+!@
+!@ SCRIPR
+!@
+!@ -- lg_vector: Logical indicating if vector fields are treated
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: neighbor, ntronca, ncofld
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: neighborg, nbofld, nbnfld
+  INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: nludat
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nlufil, nlumap 
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nmapfl, nmapvoi, nlusub
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nsubfl, nsubvoi, nluext
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nextfl, nosper, notper
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE ::  ntinpflx, ntoutflx, nbins
+  INTEGER (kind=ip_intwp_p) :: nlucor
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE ::  nscripvoi
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE ::  ig_assoc_input_field
+  !
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: amskval, amskvalnew
+  REAL (kind=ip_realwp_p), DIMENSION(:,:), ALLOCATABLE :: acocoef, abocoef, abncoef
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: afldcoef, afldcobo, afldcobn
+  !
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cxordbf, cyordbf
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cxordaf, cyordaf
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cextmet, cintmet
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cgrdtyp, cfldtyp
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfilfic, cfilmet 
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cconmet, cfldcoa
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cfldfin
+  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: ccofld, cbofld
+  CHARACTER(len=8), DIMENSION(:,:),ALLOCATABLE :: cbnfld, ccofic
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cdqdt, cgrdmap
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmskrd, cgrdsub
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: ctypsub, cgrdext
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: csper,ctper
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cmap_method, corder
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cnorm_opt, cfldtype
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: crsttype
+  CHARACTER(len=8) :: cfldcor
+  CHARACTER(len=8), DIMENSION(:),ALLOCATABLE :: cg_assoc_input_field
+  !      
+  LOGICAL, DIMENSION(:),ALLOCATABLE :: lsurf, lrotate
+  LOGICAL :: lg_vector  
+
+  !    -------------------------------------------------------------------
+
+END MODULE mod_analysis
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_bicub.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_bicub.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_bicub.f	(revision 1677)
@@ -0,0 +1,130 @@
+      MODULE mod_bicub
+      CONTAINS
+      SUBROUTINE bicub ( pout, px, py, kndx, kndy, pax, pay, kpts
+     $                 , pin, ki, kj)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *bicub* - Bicubic interpolation
+C
+C     Purpose: Proceed to a bicubic interpolation
+C     -------
+C     Warning : this interpolation is correct ONLY for a regular source grid
+C
+C
+C**   Interface:
+C     ---------
+C     *CALL* *bicub* ( zo, px, py, kndx, kndy, pax, pay, kpts
+C     $                 , z, ki, kj)
+C
+C**   Method
+C     ------
+C
+C     *   *   *   *
+C
+C     *   *   *   *
+C           #        ==>   pt (x,y)
+C     *  (=)  *   *  ==> = pt (kndx, kndy)
+C
+C     *   *   *   *
+C
+C     Input:
+C     -----
+C                px      : longitudes of target grid
+C                py      : latitudes of target grid
+C                kndx    : index of source point in source longitude
+C                kndy    : index of source point in source latitude
+C                pax     : longitudes of source grid
+C                pay     : latitudes of source grid
+C                kpts    : dimension of target grid
+C                pin     : input field on source grid
+C                ki, kj  : dimension of source grid
+C
+C     Output:
+C     ------
+C                pout    : interpolated field on target grid
+C
+C     Workspace:
+C     ---------
+C     Local variables
+C          zy1, zy2, zy3, zy4, i, j, zdx, zdy ,z1, z2, z3, z4
+C     Statement function
+C          cubic
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C *
+      IMPLICIT NONE
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: kpts, ki, kj
+      REAL, DIMENSION ( kpts), INTENT ( in) :: px, py
+      REAL, DIMENSION ( -1: ki + 2), INTENT ( in) :: pax
+      REAL, DIMENSION ( -1: kj + 2), INTENT ( in) :: pay
+      REAL, DIMENSION ( -1: ki + 2, -1: kj + 2), INTENT ( in) :: pin 
+      INTEGER, DIMENSION ( kpts), INTENT ( in) :: kndx, kndy
+      REAL, DIMENSION ( kpts), INTENT ( out) :: pout
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL    :: zy1, zy2, zy3, zy4
+      INTEGER :: jn, ji, jj
+C
+C* ---------------------------- Statement fucntions----------------------
+C
+      REAL  ::  cubic, zdx, zdy , z1, z2, z3, z4
+C
+      cubic ( z1, z2, z3, z4, zdx) = (((( z4 - z1)*0.1666666666666 
+     $    + 0.5 * ( z2 - z3)
+     $    ) * zdx + 0.5 * ( z1 + z3) - z2) * zdx + z3 
+     $    - 0.1666666666666 * z4 - 0.5 * z2 - 0.
+     $    3333333333333 * z1) * zdx + z2
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Interpolation
+C        -------------
+C
+      DO jn = 1, kpts
+        ji  = kndx ( jn)
+        jj  = kndy ( jn)
+        zdx = ( px ( jn) - pax ( ji)) / ( pax ( ji + 1) - pax ( ji))
+        zdy = ( py ( jn) - pay ( jj)) / ( pay ( jj + 1) - pay ( jj))
+        zy1 = cubic ( pin ( ji-1, jj-1), pin ( ji  , jj-1)
+     $      ,         pin ( ji+1, jj-1), pin ( ji+2, jj-1), zdx)
+        zy2 = cubic ( pin ( ji-1, jj  ), pin ( ji  , jj  )
+     $      ,         pin ( ji+1, jj  ), pin ( ji+2, jj  ), zdx)
+        zy3 = cubic ( pin ( ji-1, jj+1), pin ( ji  , jj+1)
+     $      ,         pin ( ji+1, jj+1), pin ( ji+2, jj+1), zdx)
+        zy4 = cubic ( pin ( ji-1, jj+2), pin ( ji  , jj+2) 
+     $      ,         pin ( ji+1, jj+2), pin ( ji+2, jj+2), zdx)
+        pout ( jn) = cubic ( zy1, zy2, zy3, zy4, zdy)
+      END DO
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      RETURN
+      END SUBROUTINE bicub
+      END MODULE mod_bicub
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_bilin.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_bilin.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_bilin.f	(revision 1677)
@@ -0,0 +1,118 @@
+      MODULE mod_bilin
+      CONTAINS
+      SUBROUTINE bilin ( pout, px, py, kndx, kndy, pax, pay, kpts
+     $                 , pin, ki, kj)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *bilin* - Bilinear interpolation
+C
+C     Purpose: Proceed to a bilinear interpolation
+C     -------
+C
+C
+C**   Interface:
+C     ---------
+C     *CALL* *bilin* ( zo, px, py, kndx, kndy, pax, pay, kpts
+C     $                 , z, ki, kj)
+C
+C**   Method
+C     ------
+C
+C     *   *   *   *
+C
+C     *   *   *   *
+C           #        ==>   pt (x,y)
+C     *  (=)  *   *  ==> = pt (kndx, kndy)
+C
+C     *   *   *   *
+C
+C     Input:
+C     -----
+C                px      : longitudes of target grid
+C                py      : latitudes of target grid
+C                kndx    : index of source point in source longitude
+C                kndy    : index of source point in source latitude
+C                pax     : longitudes of source grid
+C                pay     : latitudes of source grid
+C                kpts    : dimension of target grid
+C                pin     : input field on source grid
+C                ki, kj  : dimension of source grid
+C
+C     Output:
+C     ------
+C                pout    : interpolated field on target grid
+C
+C     Workspace:
+C     ---------
+C     Local variables
+C          zy1, zy2, zy3, zy4, i, j, zdx, zdy ,z1, z2, z3, z4
+C     Statement function
+C          cubic
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C *
+      IMPLICIT NONE
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: kpts, ki, kj
+      REAL, DIMENSION ( kpts), INTENT ( in) :: px, py
+      REAL, DIMENSION ( 0: ki + 1), INTENT ( in) :: pax
+      REAL, DIMENSION ( 0: kj + 1), INTENT ( in) :: pay
+      REAL, DIMENSION ( 0: ki + 1, 0: kj + 1), INTENT ( in) :: pin 
+      INTEGER, DIMENSION ( kpts), INTENT ( in) :: kndx, kndy
+      REAL, DIMENSION ( kpts), INTENT ( out) :: pout
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL    :: zy1, zy2
+      INTEGER :: jn, ji, jj
+C
+C* ---------------------------- Statement fucntions----------------------
+C
+      REAL  ::  zlinear, zdx, zdy , z1, z2
+C
+      zlinear ( z1, z2, zdx) = ( 1.0  - zdx) * z1 + zdx * z2
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Interpolation
+C        -------------
+C
+      DO jn = 1, kpts
+        ji  = kndx ( jn) ; jj  = kndy ( jn)
+        zdx = ( px ( jn) - pax ( ji)) / ( pax ( ji + 1) - pax ( ji))
+        zdy = ( py ( jn) - pay ( jj)) / ( pay ( jj + 1) - pay ( jj))
+        zy1 = zlinear ( pin ( ji, jj  ), pin ( ji+1, jj  ), zdx)
+        zy2 = zlinear ( pin ( ji, jj+1), pin ( ji+1, jj+1), zdx)
+        pout ( jn) = zlinear ( zy1, zy2, zdy)
+      END DO
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      RETURN
+      END SUBROUTINE bilin
+      END MODULE mod_bilin
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_calendar.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_calendar.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_calendar.F90	(revision 1677)
@@ -0,0 +1,71 @@
+MODULE mod_calendar
+!
+! -- calendar.h   01-11-95   Version 2.0   Author: Laurent Terray
+!    **********
+!@
+!@  Contents : variables related to the coupler calendar
+!@  --------
+!@
+!@ -- nddeb : beginning date of the simulation (yyyymmdd)
+!@            (always 00000000 in blkdata.f, not present in namcouple)
+!@
+!@ -- nadeb : beginning year of the simulation (yy)
+!@            (always 00 as ndded always 00000000)
+!@
+!@ -- nmdeb : beginning month of the simulation (mm)
+!@            (always 00 as ndded always 00000000)
+!@
+!@ -- njdeb : beginning day of the simulation (dd)
+!@            (always 00 as ndded always 00000000)
+!@
+!@ -- ndate : initial date (yyyymmdd)
+!@
+!@ -- njini : initial day (dd)
+!@
+!@ -- nmini : initial month (mm)
+!@
+!@ -- naini : initial year (yy)
+!@
+!@ -- njnow : current day (dd)
+!@ 
+!@ -- njone : inf. day limit for linear time interpolation (dd)
+!@              'sea <<<--->>> sea' case
+!@
+!@ -- njtwo : sup. day limit for linear time interpolation (dd)
+!@              'sea <<<--->>> sea' case
+!@
+!@ -- ndone : inf. day limit for linear time interpolation (dd)
+!@              'sea <<<--->>> ice' case
+!@
+!@ -- ndtwo : sup. day limit for linear time interpolation (dd)
+!@              'sea <<<--->>> ice' case
+!@
+!@ -- nmnow : current month (mm)
+!@
+!@ -- nmone : inf. month limit for linear time interpolation (mm)
+!@
+!@ -- nmtwo : sup. month limit for linear time interpolation (mm)
+!@
+!@ -- nanow : current year (yy)
+!@
+!@ -- ndinc : day increment for each coupler time step
+!@
+!@ -- nsrec : number of records to be skipped in climatology (SE) file
+!@
+!@ -- nmrec : number of records to be skipped in interannual (MO) file
+!@
+!@ -- ncaltype : calendar type
+!@                 0      = 365 day calendar (no leap years)
+!@                 1      = Gregorian calendar
+!@                 n (>1) = n day month caledar
+!@
+!@     -------------------------------------------------------------------
+  USE mod_kinds_oasis
+  INTEGER(kind=ip_intwp_p) :: ndate, njini, nmini, naini, njnow,njone, njtwo
+  INTEGER(kind=ip_intwp_p) :: ndtwo, nmnow,nmone, nmtwo, nanow, ndinc, nsrec
+  INTEGER(kind=ip_intwp_p) :: ndone, nmrec
+  INTEGER(kind=ip_intwp_p) :: ncaltype, nddeb, nadeb, nmdeb, njdeb
+  INTEGER(kind=ip_intwp_p) :: ig_date(6)
+!
+END MODULE mod_calendar
+!     -------------------------------------------------------------------
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_coast.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_coast.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_coast.F90	(revision 1677)
@@ -0,0 +1,38 @@
+MODULE mod_coast
+!
+! -- coast.h   01-11-95   Version 2.0   Author: Laurent Terray
+!    *******
+!@
+!@  Contents : variables and arrays related to the coast correction
+!@  --------
+!@
+!@ Anaism --->>>
+!@
+!@    Rappel:
+!@ -- nmesh : number of ocean gcm-1 squares overlapped by a given gcm-2 
+!@            square (1D)
+!@    End of rappel
+!@
+!@ -- ncoast : number of coastal ocean squares on the gcm-2 grid for which
+!@              there are no underlying ocean squares on the gcm-1 grid
+!@
+!@ -- npcoast : coast mismatch data array (2D)
+!@              (n,1) --> 1D index of nth point described above
+!@              (n,2) --> number of neighbours suitable for extrapolating SST
+!@              (n,3-6) --> 1D indices of neighbours of nth point
+!@ 
+!@ -- nfcoast : flag to perform coast mismatch correction
+!@
+!@ -- lcoast  : initialization flag
+!@
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: npcoast
+  INTEGER (kind=ip_intwp_p) :: ncoast, nfcoast
+!
+  LOGICAL :: lcoast
+!
+! -------------------------------------------------------------------
+!
+END MODULE mod_coast
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_experiment.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_experiment.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_experiment.F90	(revision 1677)
@@ -0,0 +1,48 @@
+MODULE mod_experiment
+!
+! -- experiment.h   26-08-95   Version 2.0   Author: Laurent Terray
+!    ************   14-12-97   Version 2.2   addition of info mode (lmodinf)
+!                   14-03-99   Version 2.3   CHARACTER*4 cjobnam (S. Valcke)
+!                   07-09-00   Version 2.5   INTEGER nbcplproc (S. Valcke)
+!                                            INTEGER nbtotproc
+!                                            CHARACTER*80 cmpiarg
+!                   18-03-02   Version 2.5   changed in module    
+!@
+!@  !ontents : variables related to the simulation being performed
+!@  --------
+!@
+!@ -- cjobnam : experiment name
+!@
+!@ -- cmodnam : models name 
+!@
+!@ -- nmodel : number of models being coupled
+!@
+!@ -- nmseq : number of sequential models
+!@
+!@ -- lmodinf : information mode (extended header)
+!@
+!@ -- nbcplproc: number of model processes implied in the coupling
+!@
+!@ -- nbtotproc: total number of model processes
+!@
+!@ -- cmpiarg: launching argument for each model
+!
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p) :: nmseq
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nbcplproc, nbtotproc
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iga_unitmod
+!
+  CHARACTER(len=4) :: cjobnam
+  CHARACTER(len=6), DIMENSION(:), ALLOCATABLE :: cmodnam
+  CHARACTER(len=80), DIMENSION(:), ALLOCATABLE :: cmpiarg
+!
+  LOGICAL :: lmodinf
+!
+!     -------------------------------------------------------------------
+!
+END MODULE mod_experiment
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_extrapol.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_extrapol.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_extrapol.F90	(revision 1677)
@@ -0,0 +1,66 @@
+MODULE mod_extrapol
+!
+! -- extrapol.h   16-12-97   Version 2.2   Author: Laurent Terray
+!    **********   30-03-99   Version 2.3   READ/WRITE flag, FILE and dataset
+!                                           index for NINENN weights
+!                 18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : variables and arrays related to extrapolation
+!@  --------
+!@
+!@ WEIGHT --->>>
+!@
+!@ -- aextra : weight for each gcm-1 mesh proportional to overlapped area (1D)
+!@
+!@ -- nextra : neighbors adress on gcm-1 grid for a given gcm-2 grid point (1D)
+!@
+!@ -- lextra : I/O initialization flag for each field
+!@
+!@ NINENN --->>>
+!@
+!@ -- niwtn : flag to read/write EXTRAP/NINENN parameters (1D)
+!@
+!@ -- niwtng : flag to read/write EXTRAP/NINENN parameters when extrap
+!@             is called by GLORED (1D)
+!@
+!@ -- cwninenn : file name for NINENN parameter FILE
+!@
+!@ -- nninnfl : flag to identify different EXTRAP/NINENN parameter sets 
+!@              within all NINENN/EXTRAP analyses (1D)
+!@
+!@ -- nninnflg : flag to identify different EXTRAP/NINENN parameter sets 
+!@               WHEN extrap is called by GLORED within all NINENN/EXTRAP
+!@               analyses (1D)
+!@
+!@ COMMON --->>>
+!@
+!@ -- lweight : flag indicating IF EXTRAP/NINENN parameter sets have 
+!@              already been calculated or read (.TRUE.) or not (.FALSE.)
+!@
+!@ -- lextrapdone : logical indicating if EXTRAP analysis has been done 
+!@                  for field
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+!
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nextra
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtn, nninnfl 
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: niwtng, nninnflg
+  INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: iincre
+  INTEGER (kind=ip_intwp_p), DIMENSION(:,:,:), ALLOCATABLE :: iaddress
+!
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: aextra
+  REAL (kind=ip_realwp_p), DIMENSION(:,:,:), ALLOCATABLE :: zweights
+!
+  LOGICAL, DIMENSION(:), ALLOCATABLE :: lextra, lweight
+  LOGICAL, DIMENSION(:), ALLOCATABLE :: lextrapdone
+!
+  CHARACTER(len=8), PARAMETER ::  cwninenn = 'nweights'
+!
+!
+! -------------------------------------------------------------------
+!
+END MODULE mod_extrapol
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_findlin.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_findlin.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_findlin.f	(revision 1677)
@@ -0,0 +1,196 @@
+      MODULE mod_findlin
+      CONTAINS
+      SUBROUTINE findlin ( px, py, kpts, pax, pay, ki, kj,
+     $                 kndx, kndy, plx, ply, ldnorth, ldsouth)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pos* - Computes position of points in a longitude-latitude grid
+C
+C     Purpose:
+C     -------
+C**   Interface:
+C     ---------
+C       *CALL*  *findlin* ( px, py, kpts, pax, pay, ki, kj,
+C     $                 kndx, kndy, plx, ply, ldnorth, ldsouth) 
+C
+C     Input:
+C     -----
+C                px      : longitudes of target grid
+C                py      : latitudes of target grid
+C                kpts    : dimension of target grid
+C                pax     : longitudes of source grid
+C                pay     : latitudes of source grid
+C                ki, kj  : dimension of source grid
+C
+C     Output:
+C     ------
+C                plx     : extended longitudes of source grid
+C                ply     : extended latitudes of source grid
+C                ldnorth : TRUE if north pole is a point of the grid
+C                ldsouth : TRUE if south pole is a point of the grid
+C
+C     Workspace:
+C     ---------
+C     Local variables
+C                ji, jj, jn, ilo, ihi, zxmin, zxmax, zymin, zymax
+C                iimin, iimax, ijmin, ijmax
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C 
+      IMPLICIT none
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: kpts, ki, kj
+      REAL, DIMENSION ( kpts), INTENT ( inout) :: px, py
+      INTEGER, DIMENSION ( kpts), INTENT ( out) :: kndx, kndy
+      REAL, DIMENSION ( ki), INTENT ( in) :: pax
+      REAL, DIMENSION ( kj), INTENT ( in) :: pay
+      REAL, DIMENSION ( 0: ki + 1), INTENT ( out) :: plx
+      REAL, DIMENSION ( 0: kj + 1), INTENT ( out) :: ply
+      LOGICAL, INTENT ( out) :: ldnorth, ldsouth
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER :: ji, jj, jn
+      INTEGER :: ilo, ihi
+      REAL    :: zxmin, zxmax, zymin, zymax
+      INTEGER :: iimin, iimax, ijmin, ijmax
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+C
+C* Extension of source grid
+C
+C For longitudinal, by periodicity
+C
+      plx ( 1: ki) = pax ( 1: ki)
+      plx (   0   ) = plx ( ki    ) - 360.0
+      plx ( ki + 1) = plx (   1   ) + 360.0
+C
+C  For latitudinal
+C
+      ply ( 1: kj) = pay ( 1: kj)
+C
+C* Point at the south pole ?
+C
+      IF ( abs ( ply ( 1) - ( -90.0)) .LT. 1.0e-1) THEN 
+          ply (  0) = -180.0 - ply ( 2) 
+          ply (  1) = -90.0
+          ldsouth = .TRUE.
+      ELSE 
+          ply (  0) = -180.0 - ply ( 1)
+          ldsouth = .FALSE.
+      ENDIF
+C
+C* Point at the north pole ?
+C
+      IF ( abs ( ply ( kj) - 90.0 ) .LT. 1.0E-1 ) THEN 
+          ply ( kj    ) = 90.0
+          ply ( kj + 1) = 180.0 - ply ( kj - 1)
+          ldnorth = .TRUE.
+      ELSE 
+          ply ( kj + 1) = 180.0 - ply ( kj)
+          ldnorth = .FALSE.
+      ENDIF 
+C
+C Verif
+      zxmin = MINVAL ( plx) ; zxmax = MAXVAL ( plx)
+      zymin = MINVAL ( ply) ; zymax = MAXVAL ( ply)
+C
+C* Set TARGET grid within the limits of the source grid
+C
+      zxmin = plx ( 1)
+      zxmax = plx ( 1) + 360.0
+      DO jn = 1, kpts
+        IF ( px ( jn) .LT. zxmin) THEN
+            px ( jn) = px ( jn) + 360.0
+        ELSE IF ( px ( jn) .GT. zxmax) THEN
+            px ( jn) = px ( jn) - 360.0
+        ENDIF 
+      END DO 
+C
+C 2. Seek the POSITION of TARGET point by bisection
+C
+      iimin = ki + 10 ; iimax = -10 ; ijmin = kj + 10 ; ijmax = -10
+C
+      DO jn = 1, kpts
+C
+C* Longitude
+C
+        ilo = 0
+        ihi = ki
+        ji  = ( ilo + ihi) / 2
+ 1111   CONTINUE 
+        IF ( ( ihi - ilo) .GT. 1 ) THEN
+            IF ( px ( jn) .LE. plx ( ji) ) THEN
+                ihi = ji
+            ELSE
+                ilo = ji
+            ENDIF 
+            ji = ( ilo + ihi) / 2
+            GO TO 1111
+        ENDIF 
+        kndx ( jn) = ilo
+C
+C* Latitude
+C
+        ilo = 0
+        ihi = kj
+        jj  = ( ilo + ihi) / 2
+ 2222   CONTINUE 
+        IF ( ( ihi - ilo) .GT. 1 ) THEN
+            IF ( py ( jn) .LE. ply ( jj) ) THEN
+                ihi = jj
+            ELSE
+                ilo = jj
+            ENDIF 
+            jj = ( ilo + ihi) / 2
+            GO TO 2222
+        ENDIF 
+        kndy ( jn) = ilo
+C
+        iimin = min ( iimin, kndx ( jn))
+        iimax = max ( iimax, kndx ( jn))
+        ijmin = min ( ijmin, kndy ( jn))
+        ijmax = max ( ijmax, kndy ( jn))
+      END DO 
+C
+      IF ( iimin .LT.  0 )  
+     $    CALL halte ('STOP in pos iimin incorrect')
+      IF ( iimax .LT.  0 )  
+     $    CALL halte ('STOP in pos iimax incorrect')
+      IF ( ijmin .LT.  0 )  
+     $    CALL halte ('STOP in pos ijmin incorrect')
+      IF ( ijmax .LT.  0 )  
+     $    CALL halte ('STOP in pos ijmax incorrect')
+C
+C*    3. End of routine
+C        --------------
+      RETURN 
+      END SUBROUTINE findlin
+      END MODULE mod_findlin
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_findpos.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_findpos.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_findpos.f	(revision 1677)
@@ -0,0 +1,202 @@
+      MODULE mod_findpos
+      CONTAINS
+      SUBROUTINE findpos ( px, py, kpts, pax, pay, ki, kj,
+     $                 kndx, kndy, plx, ply, ldnorth, ldsouth)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *pos* - Computes position of points in a longitude-latitude grid
+C
+C     Purpose:
+C     -------
+C**   Interface:
+C     ---------
+C       *CALL*  *findpos* ( px, py, kpts, pax, pay, ki, kj,
+C     $                 kndx, kndy, plx, ply, ldnorth, ldsouth) 
+C
+C     Input:
+C     -----
+C                px      : longitudes of target grid
+C                py      : latitudes of target grid
+C                kpts    : dimension of target grid
+C                pax     : longitudes of source grid
+C                pay     : latitudes of source grid
+C                ki, kj  : dimension of source grid
+C
+C     Output:
+C     ------
+C                plx     : extended longitudes of source grid
+C                ply     : extended latitudes of source grid
+C                ldnorth : TRUE if north pole is a point of the grid
+C                ldsouth : TRUE if south pole is a point of the grid
+C
+C     Workspace:
+C     ---------
+C     Local variables
+C                ji, jj, jn, ilo, ihi, zxmin, zxmax, zymin, zymax
+C                iimin, iimax, ijmin, ijmax
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C 
+      IMPLICIT none
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: kpts, ki, kj
+      REAL, DIMENSION ( kpts), INTENT ( inout) :: px, py
+      INTEGER, DIMENSION ( kpts), INTENT ( out) :: kndx, kndy
+      REAL, DIMENSION ( ki), INTENT ( in) :: pax
+      REAL, DIMENSION ( kj), INTENT ( in) :: pay
+      REAL, DIMENSION ( -1: ki + 2), INTENT ( out) :: plx
+      REAL, DIMENSION ( -1: kj + 2), INTENT ( out) :: ply
+      LOGICAL, INTENT ( out) :: ldnorth, ldsouth
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER :: ji, jj, jn
+      INTEGER :: ilo, ihi
+      REAL    :: zxmin, zxmax, zymin, zymax
+      INTEGER :: iimin, iimax, ijmin, ijmax
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+C
+C* Extension of source grid
+C
+C For longitudinal, by periodicity
+C
+      plx ( 1: ki) = pax ( 1: ki)
+      plx (  -1   ) = plx ( ki - 1) - 360.0
+      plx (   0   ) = plx ( ki    ) - 360.0
+      plx ( ki + 1) = plx (   1   ) + 360.0
+      plx ( ki + 2) = plx (   2   ) + 360.0
+C
+C  For latitudinal
+C
+      ply ( 1: kj) = pay ( 1: kj)
+C
+C* Point at the south pole ?
+C
+      IF ( abs ( ply ( 1) - ( -90.0)) .LT. 1.0e-1) THEN 
+          ply ( -1) = -180.0 - ply ( 3)
+          ply (  0) = -180.0 - ply ( 2) 
+          ply (  1) = -90.0
+          ldsouth = .TRUE.
+      ELSE 
+          ply ( -1) = -180.0 - ply ( 2)
+          ply (  0) = -180.0 - ply ( 1)
+          ldsouth = .FALSE.
+      ENDIF
+C
+C* Point at the north pole ?
+C
+      IF ( abs ( ply ( kj) - 90.0 ) .LT. 1.0E-1 ) THEN 
+          ply ( kj    ) = 90.0
+          ply ( kj + 1) = 180.0 - ply ( kj - 1)
+          ply ( kj + 2) = 180.0 - ply ( kj - 2)
+          ldnorth = .TRUE.
+      ELSE 
+          ply ( kj + 1) = 180.0 - ply ( kj)
+          ply ( kj + 2) = 180.0 - ply ( kj - 1)
+          ldnorth = .FALSE.
+      ENDIF 
+C
+C Verif
+      zxmin = MINVAL ( plx) ; zxmax = MAXVAL ( plx)
+      zymin = MINVAL ( ply) ; zymax = MAXVAL ( ply)
+C
+C* Set TARGET grid within the limits of the source grid
+C
+      zxmin = plx ( 1)
+      zxmax = plx ( 1) + 360.0
+      DO jn = 1, kpts
+        IF ( px ( jn) .LT. zxmin) THEN
+            px ( jn) = px ( jn) + 360.0
+        ELSE IF ( px ( jn) .GT. zxmax) THEN
+            px ( jn) = px ( jn) - 360.0
+        ENDIF 
+      END DO 
+C
+C 2. Seek the POSITION of TARGET point by bisection
+C
+      iimin = ki + 10 ; iimax = -10 ; ijmin = kj + 10 ; ijmax = -10
+C
+      DO jn = 1, kpts
+C
+C* Longitude
+C
+        ilo = -1
+        ihi = ki + 1
+        ji  = ( ilo + ihi) * 0.5
+ 1111   CONTINUE 
+        IF ( ( ihi - ilo) .GT. 1 ) THEN
+            IF ( px ( jn) .LE. plx ( ji) ) THEN
+                ihi = ji
+            ELSE
+                ilo = ji
+            ENDIF 
+            ji = ( ilo + ihi) * 0.5 
+            GO TO 1111
+        ENDIF 
+        kndx ( jn) = ilo
+C
+C* Latitude
+C
+        ilo = -1
+        ihi = kj + 1
+        jj  = ( ilo + ihi) * 0.5
+ 2222   CONTINUE 
+        IF ( ( ihi - ilo) .GT. 1 ) THEN
+            IF ( py ( jn) .LE. ply ( jj) ) THEN
+                ihi = jj
+            ELSE
+                ilo = jj
+            ENDIF 
+            jj = ( ilo + ihi) * 0.5
+            GO TO 2222
+        ENDIF 
+        kndy ( jn) = ilo
+C
+        iimin = min ( iimin, kndx ( jn))
+        iimax = max ( iimax, kndx ( jn))
+        ijmin = min ( ijmin, kndy ( jn))
+        ijmax = max ( ijmax, kndy ( jn))
+      END DO 
+C
+      IF ( iimin .LT.  0 )  
+     $    CALL halte ('STOP in pos iimin incorrect')
+      IF ( iimax .LT.  0 )  
+     $    CALL halte ('STOP in pos iimax incorrect')
+      IF ( ijmin .LT.  0 )  
+     $    CALL halte ('STOP in pos ijmin incorrect')
+      IF ( ijmax .LT.  0 )  
+     $    CALL halte ('STOP in pos ijmax incorrect')
+C
+C*    3. End of routine
+C        --------------
+      RETURN 
+      END SUBROUTINE findpos
+      END MODULE mod_findpos
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_gauss.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_gauss.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_gauss.F90	(revision 1677)
@@ -0,0 +1,93 @@
+MODULE mod_gauss
+!
+! -- gauss.h   29-09-95   Version 2.0   Author: Laurent Terray
+!    *******   25-10-96   Version 2.1   Addition of amskred
+!              16-03-99   Version 2.3   Addition of T213 and T319
+!              26-03-99   Version 2.3   Changed troncature for number of 
+!                                        latitude between equator and pole
+!@
+!@  Contents : variables related to gaussian troncature (if any spectral model)
+!@  --------
+!@
+!@ -ninip16: number of longitudes for the 16 latitude circles (T21) (1D)
+!@
+!@ -ninip24: number of longitudes for the 24 latitude circles (T31) (1D)
+!@
+!@ -ninip32: number of longitudes for the 32 latitude circles (T42) (1D)
+!@
+!@ -ninip48: number of longitudes for the 48 latitude circles (T63) (1D)
+!@
+!@ -ninip80: number of longitudes for the 80 latitude circles (T106) (1D)
+!@
+!@ -ninip160: number of longitudes for the 160 latitude circles (T213-319) (1D)
+!@
+!@ -- nredu16 : number of points on T21 reduced gaussian grid
+!@
+!@ -- nredu24 : number of points on T31 reduced gaussian grid
+!2
+!@ -- nredu32 : number of points on T42 reduced gaussian grid
+!@
+!@ -- nredu48 : number of points on T63 reduced gaussian grid
+!@
+!@ -- nredu80 : number of points on T106 reduced gaussian grid
+!@
+!@ -- nredu160 : number of points on T213-T319 reduced gaussian grids
+!@
+!@ -- amskred : mask value for reduced grid
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+! - T21
+  INTEGER (kind=ip_intwp_p), dimension(16), PARAMETER :: ninip16 = &
+     (/20,30,40,48,54,60,64,64,64,64,64,64,64,64,64,64/)
+! - T31
+  INTEGER (kind=ip_intwp_p), dimension(24), PARAMETER :: ninip24 = &
+     (/20,30,40,48,54,60,64,64,64,64,64,64,64,64,64,64, &
+     96,96,96,96,96,96,96,96/)
+! - T42
+  INTEGER (kind=ip_intwp_p), dimension(32), PARAMETER :: ninip32 = &
+     (/20,30,40,48,48,54,54,64,72,80,80,90,96,100, &
+     108,108,120,120,120,128,128,128,128,128, &
+     128,128,128,128,128,128,128,128/)
+! - T63
+  INTEGER (kind=ip_intwp_p), dimension(48), PARAMETER :: ninip48 = &
+     (/16, 16, 18, 24, 30, 36, 48, 48, 54, 60, 72, 72, 80, 90, 90 &
+     ,96,100,108,120,120,128,128,144,144,144,144,150,160,160,160 &
+     ,162,180,180,180,180,180,180,192,192,192,192,192,192,192,192 &
+     ,192,192,192/)
+! - T106
+  INTEGER (kind=ip_intwp_p), dimension(80), PARAMETER :: ninip80 = &
+     (/16, 16, 18, 24, 30, 36, 48, 50, 60, 64, 72, 80, 80, 90, 96 &
+     ,100,108,120,120,128,128,144,144, 144,150,160,162,180,180,180 &
+     ,192,192,192,200,216,216,216,216, 240,240,240,240,240,250,250 &
+     ,250,256,270,270,270,270,288,288, 288,288,288,288,300,300,300 &
+     ,300,300,320,320,320,320,320,320, 320,320,320,320,320,320,320 &
+     ,320,320,320,320,320/)
+!- T213- T319
+  INTEGER (kind=ip_intwp_p), dimension(160), PARAMETER  :: ninip160 = &
+     (/18, 25, 36, 40, 45, 50, 60, 64, 72, 72, 80, 90, 90, 96,108 &
+     ,120,120,125,128,135,144,150,160,160,180,180,180,192,192,200 &
+     ,216,216,225,225,240,240,243,250,256,270,270,288,288,288,300 &
+     ,300,320,320,320,320,324,360,360,360,360,360,360,375,375,375 &
+     ,384,384,400,400,400,405,432,432,432,432,432,450,450,450,450 &
+     ,480,480,480,480,480,480,480,500,500,500,500,500,512,512,540 &
+     ,540,540,540,540,540,540,540,576,576,576,576,576,576,576,576 &
+     ,576,576,600,600,600,600,600,600,600,600,600,640,640,640,640 &
+     ,640,640,640,640,640,640,640,640,640,640,640,640,640,640,640 &
+     ,640,640,640,640,640,640,640,640,640,640,640,640,640,640,640 &
+     ,640,640,640,640,640,640,640,640,640,640/)
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu16 = 1784
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu24 = 3320 
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu32 = 6232
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu48 = 12228 
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu80 = 23444 
+  INTEGER (kind=ip_intwp_p), PARAMETER  :: nredu160 = 138346
+  REAL (kind=ip_realwp_p), PARAMETER  :: amskred = 9999999.0
+!
+END MODULE mod_gauss
+!     -------------------------------------------------------------------
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_hardware.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_hardware.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_hardware.F90	(revision 1677)
@@ -0,0 +1,19 @@
+MODULE mod_hardware
+!
+! -- hardware.h   25-07-95   Version 2.0   Author: Laurent Terray
+!    **********   24-12-97   Version 2.2   addition of nsigxxx
+!                 23-10-98   Version 2.3   addition of ctype (J.Latour F.S.E.)
+!@
+!@  Contents : variables related to machine and message passing type
+!@  --------
+!@
+!@ -- cchan : type of message passing used to run OASIS (PIPE, SVIPC, CLIM)
+!@
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  CHARACTER(len=4) :: cchan
+!
+END MODULE mod_hardware
+!
+! -------------------------------------------------------------------
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_intbi.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_intbi.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_intbi.f	(revision 1677)
@@ -0,0 +1,179 @@
+      MODULE mod_intbi
+      CONTAINS
+      SUBROUTINE intbi ( pin, pax, pay, ki, kj,
+     $                   pout, px, py, kpts, ldvect)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *intbi* - Interface for bicubic interpolation
+C
+C     Purpose:
+C     -------
+C     Interpolates field with bicubic scheme
+C     Source grid : global periodic grid, longitude/latitude, possibly irregular
+C     Target grid : any
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *intbi* ( pin, pax, pay, ki, kj,
+C     $                  pout, px, py, kpts, ldvect)
+C
+C     Input:
+C     -----
+C                pin       : input field on source grid
+C                pax       : longitudes of source grid
+C                pay       : latitudes of source grid
+C                ki, kj    : dimension of source grid
+C                px        : longitude of target grid
+C                py        : latitudes of target grid
+C                kpts      : dimension of target grid
+C                ldvect    : flag for vector fields                
+C
+C     Output:
+C     ------
+C                poutp     : output field on target grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     Automatic arrays (sorry: not doctor)
+C               kndx, kndy : index of target point in source grid
+C               zt         : extended input field
+C               plx        : extended longitudes of source grid
+C               ply        : extended latitudes of source grid
+C     Local variables
+C               zsgn, xmin, xmax, ymin, ymax, ji, jj
+C
+C     Externals:
+C     ---------
+C     findpos, bicub
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      USE mod_findpos
+      USE mod_bicub
+CAC
+      USE mod_unit
+CAC
+C
+      IMPLICIT NONE
+C
+C* ---------------------------- Include files ---------------------------
+C
+C
+CAC      INCLUDE 'unit.h'
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: ki, kj
+      REAL, DIMENSION ( ki, kj), INTENT ( in) :: pin
+      REAL, DIMENSION ( ki), INTENT ( in) :: pax 
+      REAL, DIMENSION ( kj), INTENT ( in) :: pay
+      LOGICAL, INTENT ( in) :: ldvect
+      INTEGER, INTENT ( in) :: kpts
+      REAL, DIMENSION ( kpts), INTENT ( inout) :: px, py
+      REAL, DIMENSION ( kpts), INTENT ( out) :: pout
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL, DIMENSION ( -1: ki + 2, -1: kj + 2) :: zt
+      REAL, DIMENSION ( -1: ki + 2) :: plx
+      REAL, DIMENSION ( -1: kj + 2) :: ply
+      INTEGER, DIMENSION ( kpts) :: kndx, kndy
+      LOGICAL :: llnorth, llsouth
+      REAL    :: zsgn, xmin, xmax, ymin, ymax
+      INTEGER :: ji, jj
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE intbi  -  Level 3'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' Bicubic nterpolation package '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Print some informations on source grid
+C
+      xmin = MINVAL ( pax) ; xmax = MAXVAL ( pax)
+      ymin = MINVAL ( pay) ; ymax = MAXVAL ( pay)
+C      
+      WRITE (UNIT = nulou,FMT = *) 
+     $    'Source grid longitude extremas : ', xmin, xmax
+      WRITE (UNIT = nulou,FMT = *) 
+     $    'Source grid latitude  extremas : ', ymin, ymax
+C
+C*    2. Interpolation
+C        -------------
+C
+C* Seek position of target points in source grid
+C
+      CALL findpos ( px, py, kpts, pax, pay, ki, kj,
+     $    kndx, kndy, plx, ply, llnorth, llsouth)
+C
+C* Extend source field
+C
+      zt ( 1:ki, 1:kj) = pin ( :, :)
+C
+C* Periodicity
+C
+      zt (    0  , 1:kj ) = pin ( ki    , 1:kj )
+      zt (   -1  , 1:kj ) = pin ( ki - 1, 1:kj )
+      zt ( ki + 1, 1:kj ) = pin (   1   , 1:kj )
+      zt ( ki + 2, 1:kj ) = pin (   2   , 1:kj )
+C
+C * Filling near poles
+C
+      zsgn = 1.0
+      IF ( ldvect ) zsgn = -1.0
+      IF ( llsouth ) THEN 
+          zt ( -1: ki + 2, -1) = zsgn * zt ( -1: ki + 2,  3) 
+          zt ( -1: ki + 2,  0) = zsgn * zt ( -1: ki + 2, 2)
+      ELSE 
+          zt ( -1: ki + 2, -1) = zsgn * zt ( -1: ki + 2, 2)
+          zt ( -1: ki + 2,  0) = zsgn * zt ( -1: ki + 2, 1)
+      ENDIF 
+      IF ( llnorth ) THEN 
+          zt ( -1: ki + 2, kj + 1) = zsgn * zt ( -1: ki + 2, kj - 1)
+          zt ( -1: ki + 2, kj + 2) = zsgn * zt ( -1: ki + 2, kj - 2)
+      ELSE 
+          zt ( -1: ki + 2, kj + 1) = zsgn * zt ( -1: ki + 2, kj)
+          zt ( -1: ki + 2, kj + 2) = zsgn * zt ( -1: ki + 2, kj - 1)
+      END IF 
+C
+C* Interpolates
+C
+      CALL bicub ( pout, px, py, kndx, kndy, plx, ply, kpts 
+     $    ,        zt, ki, kj)
+C
+C*    3. End of routine
+C        --------------
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine intbi ---------'
+      CALL FLUSH (nulou)
+      RETURN
+      END SUBROUTINE intbi
+      END MODULE mod_intbi
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_intlin.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_intlin.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_intlin.f	(revision 1677)
@@ -0,0 +1,173 @@
+      MODULE mod_intlin
+      CONTAINS
+      SUBROUTINE intlin ( pin, pax, pay, ki, kj,
+     $                   pout, px, py, kpts, ldvect)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *intlin* - Interface for bilinear interpolation
+C
+C     Purpose:
+C     -------
+C     Interpolates field with bilinear scheme
+C     Source grid : global periodic grid, longitude/latitude, possibly irregular
+C     Target grid : any
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *intlin* ( pin, pax, pay, ki, kj,
+C     $                  pout, px, py, kpts, ldvect)
+C
+C     Input:
+C     -----
+C                pin       : input field on source grid
+C                pax       : longitudes of source grid
+C                pay       : latitudes of source grid
+C                ki, kj    : dimension of source grid
+C                px        : longitude of target grid
+C                py        : latitudes of target grid
+C                kpts      : dimension of target grid
+C                ldvect    : flag for vector fields                
+C
+C     Output:
+C     ------
+C                poutp     : output field on target grid (real 2D)
+C
+C     Workspace:
+C     ---------
+C     Automatic arrays (sorry: not doctor)
+C               kndx, kndy : index of target point in source grid
+C               zt         : extended input field
+C               plx        : extended longitudes of source grid
+C               ply        : extended latitudes of source grid
+C     Local variables
+C               zsgn, xmin, xmax, ymin, ymax, ji, jj
+C
+C     Externals:
+C     ---------
+C     findlin, bilin
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       O. Marti       96/07/15  Created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+      USE mod_findlin
+      USE mod_bilin
+CAC
+      USE mod_unit
+CAC
+C
+      IMPLICIT NONE
+C
+C* ---------------------------- Include files ---------------------------
+C
+C
+CAC      INCLUDE 'unit.h'
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER, INTENT ( in) :: ki, kj
+      REAL, DIMENSION ( ki, kj), INTENT ( in) :: pin
+      REAL, DIMENSION ( ki), INTENT ( in) :: pax 
+      REAL, DIMENSION ( kj), INTENT ( in) :: pay
+      LOGICAL, INTENT ( in) :: ldvect
+      INTEGER, INTENT ( in) :: kpts
+      REAL, DIMENSION ( kpts), INTENT ( inout) :: px, py
+      REAL, DIMENSION ( kpts), INTENT ( out) :: pout
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL, DIMENSION ( 0: ki + 1, 0: kj + 1) :: zt
+      REAL, DIMENSION ( 0: ki + 1) :: plx
+      REAL, DIMENSION ( 0: kj + 1) :: ply
+      INTEGER, DIMENSION ( kpts) :: kndx, kndy
+      LOGICAL :: llnorth, llsouth
+      REAL    :: zsgn, xmin, xmax, ymin, ymax
+      INTEGER :: ji, jj
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE intlin  -  Level 3'
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    ' Bilinear nterpolation package '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Print some informations on source grid
+C
+      xmin = MINVAL ( pax) ; xmax = MAXVAL ( pax)
+      ymin = MINVAL ( pay) ; ymax = MAXVAL ( pay)
+C      
+      WRITE (UNIT = nulou,FMT = *) 
+     $    'Source grid longitude extremas : ', xmin, xmax
+      WRITE (UNIT = nulou,FMT = *) 
+     $    'Source grid latitude  extremas : ', ymin, ymax
+C
+C*    2. Interpolation
+C        -------------
+C
+C* Seek position of target points in source grid
+C
+      CALL findlin ( px, py, kpts, pax, pay, ki, kj,
+     $    kndx, kndy, plx, ply, llnorth, llsouth)
+C
+C* Extend source field
+C
+      zt ( 1:ki, 1:kj) = pin ( :, :)
+C
+C* Periodicity
+C
+      zt (    0  , 1:kj ) = pin ( ki    , 1:kj )
+      zt ( ki + 1, 1:kj ) = pin (   1   , 1:kj )
+C
+C * Filling near poles
+C
+      zsgn = 1.0
+      IF ( ldvect ) zsgn = -1.0
+      IF ( llsouth ) THEN 
+          zt ( 0: ki + 1,  0) = zsgn * zt ( 0: ki + 1, 2)
+      ELSE 
+          zt ( 0: ki + 1,  0) = zsgn * zt ( 0: ki + 1, 1)
+      ENDIF 
+      IF ( llnorth ) THEN 
+          zt ( 0: ki + 1, kj + 1) = zsgn * zt ( -1: ki + 1, kj - 1)
+      ELSE 
+          zt ( 0: ki + 1, kj + 1) = zsgn * zt ( -1: ki + 1, kj)
+      END IF 
+C
+C* Interpolates
+C
+      CALL bilin ( pout, px, py, kndx, kndy, plx, ply, kpts 
+     $    ,        zt, ki, kj)
+C
+C*    3. End of routine
+C        --------------
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine intlin ---------'
+      CALL FLUSH (nulou)
+      RETURN
+      END SUBROUTINE intlin
+      END MODULE mod_intlin
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_kinds_oasis.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_kinds_oasis.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_kinds_oasis.F90	(revision 1677)
@@ -0,0 +1,39 @@
+!-------------------------------------------------------------------
+! BOP
+!
+! !MODULE: mod_kinds_oasis
+MODULE mod_kinds_oasis
+!
+! !USES:
+!
+! !PUBLIC TYPES:
+IMPLICIT NONE
+SAVE
+!
+! !PUBLIC MEMBER FUNCTIONS:
+!
+! !PUBLIC DATA MEMBERS:
+!
+! !PARAMETERS:
+  INTEGER, PARAMETER :: ip_single_p = SELECTED_REAL_KIND(6,37)
+  INTEGER, PARAMETER :: ip_double_p = SELECTED_REAL_KIND(12,307)
+#ifdef use_realtype_single
+  INTEGER, PARAMETER :: ip_realwp_p = ip_single_p
+#else
+  INTEGER, PARAMETER :: ip_realwp_p = ip_double_p  
+#endif
+  INTEGER, PARAMETER :: ip_i2_p = SELECTED_INT_KIND(4)
+  INTEGER, PARAMETER :: ip_i4_p = SELECTED_INT_KIND(9)
+#ifdef SX
+  INTEGER, PARAMETER :: ip_i8_p = SELECTED_INT_KIND(15)
+#else
+  INTEGER, PARAMETER :: ip_i8_p = SELECTED_INT_KIND(18)
+#endif
+  INTEGER, PARAMETER :: ip_intwp_p = ip_i4_p 
+!
+! !DESCRIPTION:
+! This modules contains the parameters defining the precision used for 
+! real and integer variables
+!   
+  END MODULE mod_kinds_oasis
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_label.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_label.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_label.F90	(revision 1677)
@@ -0,0 +1,49 @@
+MODULE mod_label
+!
+! -- label.h   18-08-95   Version 2.0beta   Author: Laurent Terray
+!    *******   01-02-96   Version 2.0 : disparition of ctranam
+!              07-08-96   Version 2.1 : rise of cfldlab dimension
+!              25-09-96   Version 2.1 : rise of cfldlab length
+!@
+!@  Contents : variables related to labelling files and character variable
+!@  --------
+!@
+!@ -- cfldlab : field label definition (1D)
+!@
+!@ -- cgrdnam : name for grid file
+!@
+!@ -- cmsknam : name for mask file
+!@
+!@ -- csurnam : name for surface file
+!@
+!@ -- cglonsuf : suffix name for longitude grid file locator
+!@
+!@ -- cglatsuf : suffix name for longitude latitude grid file locator
+!@
+!@ -- cmsksuf : suffix name for mask file locator
+!@
+!@ -- crnlonsuf : suffix name for corner longitude grid file locator
+!@
+!@ -- crnlatsuf : suffix name for corner latitude grid file locator
+!@
+!@ -- csursuf : suffix name for surface file locator
+!@
+!@ -- crednam : name for reduced gaussian grid masks file
+!@
+! -------------------------------------------------------------------
+!
+  CHARACTER(len=64),ALLOCATABLE::cfldlab(:)
+  CHARACTER(len=5), PARAMETER :: cgrdnam = 'grids'  
+  CHARACTER(len=5), PARAMETER :: cmsknam = 'masks' 
+  CHARACTER(len=5), PARAMETER :: csurnam = 'areas' 
+  CHARACTER(len=5), PARAMETER :: crednam = 'maskr'
+  CHARACTER(len=4), PARAMETER :: cglonsuf = '.lon'
+  CHARACTER(len=4), PARAMETER :: cglatsuf = '.lat'
+  CHARACTER(len=4), PARAMETER :: crnlonsuf = '.clo'
+  CHARACTER(len=4), PARAMETER :: crnlatsuf = '.cla'
+  CHARACTER(len=4), PARAMETER :: cmsksuf = '.msk'
+  CHARACTER(len=4), PARAMETER :: csursuf = '.srf'
+!
+END MODULE mod_label
+! -------------------------------------------------------------------
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_memory.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_memory.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_memory.F90	(revision 1677)
@@ -0,0 +1,69 @@
+MODULE mod_memory
+!
+! -- memory.h   23-08-95   Version 2.0   Author: Laurent Terray
+!    ********   
+!               18-03-98   Version 2.5   changed in module
+!@
+!@  Contents : variables related to pseudo-dynamic memory allocation
+!@  --------
+!@
+!@ -- nsizold : size for each field sub-array (before interpolation) (1D)
+!@
+!@ -- nsiznew : size for each field sub-array (after interpolation) (1D)
+!@
+!@ -- nadrold : adress for each field sub-array (before interpolation) (1D)
+!@
+!@ -- nadrold_grid : adress for each grid sub-array (before interpolation) (1D)
+!@
+!@ -- nadrnew : adress for each field sub-array (after interpolation) (1D)
+!@
+!@ -- nadrnew_grid : adress for each grid sub-array (after interpolation) (1D)
+!@
+!@ -- mskold : macro array for masks (before interpolation) (1D)
+!@
+!@ -- msknew : macro array for masks (after interpolation) (1D) 
+!@
+!@ -- nwork : integer work array (1D)
+!@
+!@ -- fldold : macro array for fields (before interpolation) (1D)
+!@
+!@ -- fldnew : macro array for fields (after interpolation) (1D)
+!@
+!@ -- xgrold : macro array for longitudes (before interpolation) (1D)
+!@
+!@ -- xgrnew : macro array for longitudes (after interpolation) (1D)
+!@
+!@ -- ygrold : macro array for latitudes (before interpolation) (1D)
+!@
+!@ -- ygrnew : macro array for latitudes (after interpolation) (1D)
+!@
+!@ -- surold : macro array for mesh surfaces (before interpolation) (1D) 
+!@
+!@ -- surnew : macro array for mesh surfaces (after interpolation) (1D)
+!@
+!@ -- work : real work array (1D)
+!@
+!     -------------------------------------------------------------------   
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+!
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nsizold, nsiznew
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nadrold, nadrnew
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nadrold_grid
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nadrnew_grid
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: mskold, msknew
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: nwork
+!
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: fldold, fldnew
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: xgrold, xgrnew
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: ygrold, ygrnew
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: surold, surnew
+  REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: work
+!
+!     -------------------------------------------------------------------   
+!
+END MODULE mod_memory
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_nproc.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_nproc.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_nproc.F90	(revision 1677)
@@ -0,0 +1,19 @@
+MODULE mod_nproc
+!
+! -- nproc.h   97-09-03   Version 2.2   Author: S. Valcke
+!    *******
+!              18-03-02   Version 2.5   changed in module
+!@
+!@  Contents :
+!@  --------
+!@
+!@ -- nproc  : process ID of each model -used in PIPE, SIPC and GMEM
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nproc
+
+!     -------------------------------------------------------------------
+
+END MODULE mod_nproc
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_parallel.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_parallel.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_parallel.F90	(revision 1677)
@@ -0,0 +1,25 @@
+MODULE mod_parallel
+!
+! -- parallel.h   11-09-95   Version 2.0   Author: Laurent Terray
+!    **********
+!                 18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : variables related to parallel data decomposition
+!@  --------
+!@
+!@ -- nparal : parallel decomposition description (see CLIM manual) (2D)
+!@
+!@ -- cparal : type of parallel decomposition (idem) (1D)
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: nparal
+!
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cparal
+!
+!     -------------------------------------------------------------------
+END MODULE mod_parallel
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_parameter.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_parameter.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_parameter.F90	(revision 1677)
@@ -0,0 +1,105 @@
+MODULE mod_parameter
+!
+! -- parameter.h   01-09-95   Version 2.0   Author: Laurent Terray
+!    ***********   05-08-96   Version 2.1 
+!                             Mods: Add parameters for mapping 
+!                                   and subgrid (L. Terray)
+!                  20-06-97   Version 2.2 Mods: Add jpbyteint (S. Valcke)
+!                  16-12-97                     Add jpext and jpnbn (L. Terray)
+!                  31-12-97                     Suppress jpwrk (L. Terray)
+!                  12-10-99   Version 2.3 Mods: Add jpnfn (S. Valcke)
+!                  28-01-00   Version 2.4 Mods :jpparal=102, jpfield=10 (J.Latour)
+!                  18-03-02   Version 2.5 changed in module (A.Caubel)
+!@
+!@  Contents : parameter file for OASIS
+!@  --------
+!@
+!@ -- ig_total_nfield : number of coupling fields
+!@
+!@ -- ig_direct_nfield : number of fields not going through Oasis
+!@
+!@ -- ig_nfield : number of fields going through Oasis
+!@
+!@ -- lg_oasis_field : logical indicating if all fields go through Oasis or not
+!@                 (.false. if all fields are exchanged directly)
+!@
+!@ -- ig_nmodel : maximum number of models
+!@
+!@ -- ig_maxcomb : maximum number of fields to be combined in the BLASxxx analyses
+!@
+!@ -- ig_maxold : Memory size of the macro arrays handling fields values
+!@
+!@ -- ig_maxnew : Memory size of the macro arrays handling fields values 
+!@
+!@ -- ig_maxold_grid : Memory size of the arrays handling field grid-related 
+!@                     data before interpolation
+!@
+!@ -- ig_maxnew_grid : Memory size of the arrays handling field grid-related 
+!@                     data after interpolation
+!@
+!@ -- ig_nwork : Size of "nwork" array
+!@
+!@ -- ig_work : Size of "work" array
+!@
+!@ -- ig_maxgrd : maximum grid size of indirect fields
+!@
+!@ -- ig_total_maxgrd : maximum grid size of all fields defined in the 
+!@                      namcouple (direct and indirect fields)
+!@
+!@ -- ig_maxwoa : maximum number of underlying neighbors for SURFMESH interpolation
+!@
+!@ -- ig_maxnoa : number of neighbors for GAUSSIAN interpolation
+!@
+!@ -- ig_maxmoa : maximum number of underlying neighbors for MOZAIC interpolation
+!@
+!@ -- ig_maxsoa : maximum number of overlaying neighbors for SUBGRID interpolation
+!@
+!@ -- ig_maxnfm : maximum number of different SURFMESH interpolations
+!@
+!@ -- ig_maxnfg : maximum number of different GAUSSIAN interpolations
+!@
+!@ -- ig_maxnfp : maximum number of different MOZAIC interpolations
+!@
+!@ -- ig_maxnfs : maximum number of different SUBGRID interpolations
+!@
+!@ -- ig_maxnfn : maximum number of different NINENN extrapolations
+!@
+!@ -- ig_maxext : maximum number of neighbors for extrapolation
+!@
+!@ -- ig_maxnbn : maximum number of different extrapolation
+!@
+!     -------------------------------------------------------------------
+!
+!* Useful numerical values
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p),PARAMETER :: jpeight = 8, jpfour = 4, jpeighty = 80
+!
+!-----Field status
+!
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_exported  = 1
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_ignored   = 2
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_input     = 3
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_output    = 4
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_expout    = 5
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_ignout    = 6
+  INTEGER(kind=ip_intwp_p), PARAMETER :: ip_auxilary  = 7
+!
+!* Essential parameters to dimension the simulation
+  INTEGER (kind=ip_intwp_p) :: ig_nmodel, ig_nfield, ig_direct_nfield, ig_total_nfield
+  LOGICAL :: lg_oasis_field
+  INTEGER (kind=ip_intwp_p) :: ig_maxcomb
+!* Parameters to dimension the main big arrays
+  INTEGER (kind=ip_intwp_p) :: ig_nwork, ig_work
+  INTEGER (kind=ip_intwp_p) :: ig_maxold, ig_maxnew
+  INTEGER (kind=ip_intwp_p) :: ig_maxold_grid, ig_maxnew_grid
+!* Parameters related to maxima of grid-dimension
+  INTEGER (kind=ip_intwp_p) :: ig_maxgrd, ig_total_maxgrd
+!* Parameters related to ANAIS(M-G), MOZAIC and SUBGRID interpolation
+  INTEGER (kind=ip_intwp_p) :: ig_maxwoa, ig_maxnoa, ig_maxmoa, ig_maxsoa
+  INTEGER (kind=ip_intwp_p) :: ig_maxnfm, ig_maxnfg, ig_maxnfp, ig_maxnfs, ig_maxnfn
+!* Parameters related to extrapolation method WEIGHT
+  INTEGER (kind=ip_intwp_p) :: ig_maxext, ig_maxnbn
+!
+!     -------------------------------------------------------------------
+!
+END MODULE MOD_PARAMETER
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_pipe.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_pipe.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_pipe.F90	(revision 1677)
@@ -0,0 +1,19 @@
+MODULE mod_pipe
+!
+! -- pipe.h   25-09-95   Version 2.0   Author: Laurent Terray
+!    ******   20-09-97   Version 2.2   Mods: suppress nproc (S. Valcke)
+!             18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : variables describing pipes (FIFO) used for message passing
+!@  --------
+!@
+!@ -- cprnam : files associated to reading model pipes (1D)
+!@
+!@ -- cpwnam : files associated to writing model pipes (1D)
+!@
+!     -------------------------------------------------------------------
+!
+  CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: cprnam, cpwnam
+!
+!     -------------------------------------------------------------------
+END MODULE mod_pipe
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_printing.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_printing.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_printing.F90	(revision 1677)
@@ -0,0 +1,22 @@
+MODULE mod_printing
+!
+! -- printing.h   30-04-99   Version 2.3   Author: Sophie Valcke
+!    **********  
+!@
+!@  Contents : variables related to printing level in cplout
+!@  --------
+!@
+!@ -- nlogprt : printing level in output file cplout: 0 = no printing
+!@      1 = main routines and field names when treated, 2 = complete output
+!@
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER(kind=ip_intwp_p) :: nlogprt
+!
+END MODULE mod_printing
+! -------------------------------------------------------------------
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_rainbow.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_rainbow.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_rainbow.F90	(revision 1677)
@@ -0,0 +1,38 @@
+MODULE mod_rainbow
+!
+! -- rainbow.h   05-08-96   Version 2.1   Author: Laurent Terray
+!    *********
+!@
+!@  Contents : variables and arrays related to mapping and subgrid interpolator
+!@  --------
+!@
+!@ Mapping --->>>
+!@
+!@ -- amapp : weight for each gcm-1 mesh proportional to overlapped area (1D)
+!@
+!@ -- nmapp : neighbors adress on gcm-1 grid for a given gcm-2 grid point (1D)
+!@
+!@ -- lmapp : I/O initialization flag for each field
+!@
+!@ Subgrid --->>>
+!@
+!@ -- asubg : weight for each gcm-2 mesh proportional to overlapped area (1D)
+!@
+!@ -- nsubg : neighbors adress on gcm-2 grid for a given gcm-1 grid point (1D)
+!@
+!@ -- lsubg : I/O initialization flag for each field
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  USE mod_parameter
+!
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nmapp, nsubg
+!
+  REAL (kind=ip_realwp_p), DIMENSION(:),ALLOCATABLE :: amapp, asubg
+!
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: lmapp, lsubg
+!
+!     -------------------------------------------------------------------
+!
+END MODULE mod_rainbow
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_sipc.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_sipc.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_sipc.F90	(revision 1677)
@@ -0,0 +1,24 @@
+MODULE mod_sipc
+!
+! -- sipc.h   97-08-11   Version 2.2   Author: S.Valcke,A.Piacentini
+!    ******
+!             18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : variables describing pools (set of shared memory segments) 
+!@  --------
+!@
+!@ -- mpoolinit(r/w) : handles associated to model pools for passing initial 
+!@                     information(1 for reading and 1 for writing)
+!@
+!@ -- mpoolidin : handles associated to pools used to pass field to oasis
+!@
+!@ -- mpoolidou : handles associated to pools used to pass field from oasis
+!@ 
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: mpoolidin, mpoolidou
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: mpoolinitr, mpoolinitw
+!
+!     -------------------------------------------------------------------
+END MODULE mod_sipc
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_smooth.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_smooth.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_smooth.F90	(revision 1677)
@@ -0,0 +1,47 @@
+MODULE mod_smooth
+!
+! -- smooth.h   01-10-95   Version 2.0   Author: Laurent Terray
+!
+!@
+!@  Contents : variables controlling how smoothing is handled
+!@  --------
+!@
+!@ Common to all N* variables :
+!@       indices for the gcm-1 grid of regions corresponding
+!@       to the boundaries of the gcm-2 domain.
+!@
+!@ -- nsltb : southern outermost point of the smoothing region
+!@
+!@ -- nslte : southern innermost point of the smoothing region
+!@
+!@ -- nnltb : northern outermost point of the smoothing region
+!@
+!@ -- nnlte : northern innermost point of the smoothing region
+!@
+!@ -- qalfa : control weights in the transition zone (north and south)
+!@
+!@ -- qbeta : control weights in the transition zone (west and east)
+!@
+!@ -- nliss : width of the smoothing region (west and east boundaries)
+!@
+!@ -- nwlgmx : longitude index of the furthest east point on the western  
+!@             boundary
+!@
+!@ -- nelgmx : longitude indexof the furthest west point on the eastern  
+!@             boundary
+!@
+! -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nsltb = 18
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nslte = 26
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nnltb = 49
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nnlte = 41
+  INTEGER(kind=ip_intwp_p), PARAMETER :: qalfa = 0.125
+  INTEGER(kind=ip_intwp_p), PARAMETER :: qbeta = 0.25
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nliss = 5
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nelgmx = 229
+  INTEGER(kind=ip_intwp_p), PARAMETER :: nwlgmx = 57
+!
+END MODULE mod_smooth
+! -------------------------------------------------------------------
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_string.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_string.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_string.F90	(revision 1677)
@@ -0,0 +1,141 @@
+MODULE mod_string
+!
+! -- string.h   26-07-95   Version 2.0   Author: Laurent Terray
+!    *******    25-09-96   Version 2.1   Addition of extra time step (nfend)
+!                                        and field integral flag (nintflx)
+!               12-11-97   Version 2.2   Addition of nmxdel
+!               05-09-00   Version 2.5   Remove integral flag nintflx   
+!               18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : set of self consistent strings for each field
+!@  --------
+!@
+!@ First line of SSCS :
+!@ ------------------
+!@
+!@ -- cnaminp : symbolic name of input indirect fields 
+!@
+!@ -- cnamout : symbolic name of output indirect fields
+!@
+!@ -- cg_input_field : symbolic name of all input fields
+!@
+!@ -- cg_output_field : symbolic name of all output fields 
+!@
+!@ -- numlab : label number of exchanged fields indirectly
+!@
+!@ -- ig_numlab : label number of all exchanged fields
+!@
+!@ -- nfexch : coupling frequency of exchanged indirect fields (in seconds)
+!@
+!@ -- ig_freq : coupling frequency of all exchanged fields (in seconds)
+!@
+!@ -- ig_ntrans : number of analysis performed for each field
+!@
+!@ -- cficinp : restart file name of indirect input fields 
+!@
+!@ -- cg_restart_file : restart file name of all input fields  
+!@
+!@ -- ig_nbr_rstfile : number of different restart file
+!@
+!@ -- ig_no_rstfile : restart file number
+!@
+!@ -- cg_name_rstfile : name of restart file corresponding to ig_no_rstfile 
+!@
+!@ -- cficout : file name for output field in cases 'PIPE' or 'NONE'
+!@
+!@ -- cg_input_file : file name for input file in cases 'IGNOUT' or 'EXPOUT'
+!@
+!@ -- ig_lag : lag of exported field
+!@
+!@ -- nluninp : logical unit for input field
+!@
+!@ -- nlunout : logical unit for output field
+!@
+!@ -- cstate : field I/O status of indirect fields
+!@
+!@ -- ig_total_state : field I/O status of all the fields
+!@
+!@ -- lg_state : LOGICAL indicating if the field goes through Oasis (.true.)
+!@               or not (.false.)
+!@
+!@ -- ifrqmin : minimum exchange frequency of indirect fields
+!@
+!@ -- ig_total_frqmin :  minimum exchange frequency of all the fields
+!@
+!@ -- ig_number_field : Rank of the field going through oasis in total number 
+!@    of fields 
+!@
+!@ -- ig_local_trans : Local transformation of fields 
+!@
+!@ Second line of SSCS :
+!@ -------------------
+!@
+!@ -- nlonbf : number of longitudes for initial fields
+!@
+!@ -- nlatbf : number of latitudes for initial fields
+!@
+!@ -- nlonaf : number of longitudes for initial fields
+!@
+!@ -- nlataf : number of latitudes for initial fields
+!@
+!@ -- cficbf : root name of specific files for initial fields
+!@
+!@ -- cficaf : root name of specific files for final fields
+!@
+!@ -- ig_grid_nbrbf : grid number associated to a field before interpolation
+!@ 
+!@ -- ig_grid_nbraf : grid number associated to a field after interpolation
+!@
+!@ -- nseqn  : sequential index of indirect fields
+!@
+!@ -- nlagn  : lag index of indirect fields
+!@
+!@ -- ig_total_nseqn : sequential index of all the fields
+!@
+!@ -- ig_invert: index=1 if INVERT is used for that field
+!@
+!@ -- ig_reverse: index=1 if REVERSE is used for that field
+!@   
+!@ Third line of SSCS :
+!@ ------------------
+!@
+!@ -- canal : names of analysis performed for each field 
+!@
+!@ Relation between symbolic name of the field and port number of 
+!@ CLIM library :
+!@  
+!@ -- ig_portin_id : port number of input fields
+!@
+!@ -- ig_portout_id : port number of output fields
+!@
+!  -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: numlab, ig_numlab, nfexch, ig_ntrans
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_total_ntrans
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nluinp, nluout, nlonbf
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nlatbf, nlonaf, nlataf
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: nseqn, ig_total_nseqn
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_freq, ig_lag, nlagn 
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_invert, ig_reverse
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_number_field, ig_no_rstfile
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_total_state, ig_local_trans
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_portin_id, ig_portout_id
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE :: ig_grid_nbrbf, ig_grid_nbraf
+  INTEGER (kind=ip_intwp_p)                          :: ifrqmin, ig_nbr_rstfile
+  INTEGER (kind=ip_intwp_p)                          :: ig_total_frqmin
+  
+  
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: lg_state
+!
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cnaminp, cnamout
+  CHARACTER(len=8),DIMENSION(:,:),ALLOCATABLE :: canal 
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cg_name_rstfile, cg_restart_file
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cficinp, cficout
+  CHARACTER(len=32),DIMENSION(:),ALLOCATABLE :: cg_input_file
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cg_input_field, cg_output_field
+  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE :: cficbf, cficaf, cstate
+  CHARACTER(len=4),DIMENSION(:),ALLOCATABLE :: cga_locatorbf, cga_locatoraf
+
+!     -------------------------------------------------------------------
+END MODULE mod_string
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_timestep.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_timestep.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_timestep.F90	(revision 1677)
@@ -0,0 +1,41 @@
+MODULE mod_timestep
+!
+! -- timestep.h   29-08-95   Version 2.0beta   Author: Laurent Terray
+!    **********   01-02-96   Version 2.0 : addition of nitfn (L. Terray)
+!                 18-03-02   Version 2.5   changed in module
+!@
+!@  Contents : variables controlling timestepping
+!@  --------
+!@
+!@   OASIS information :
+!@   -----------------
+!@
+!@ -- ntime : total simulated time (in seconds)
+!@
+!@ -- niter : number of iterations
+!@
+!@ -- nitfn : last iteration number
+!@
+!@ -- nstep : timestep value (in seconds)
+!@
+!@   Remote models information :
+!@   -------------------------
+!@
+!@ -- mstep : number of time steps (1D)
+!@
+!@ -- mfcpl : frequency of coupling in timesteps (1D)
+!@
+!@ -- mdt   : length of timesteps in seconds (1D)
+!@
+!     -------------------------------------------------------------------
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p) :: ntime, niter, nitfn, nstep
+  INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: mstep, mfcpl, mdt
+!
+!     -------------------------------------------------------------------
+!
+END MODULE mod_timestep
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_unit.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_unit.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_unit.F90	(revision 1677)
@@ -0,0 +1,54 @@
+MODULE mod_unit
+!
+! -- unit.h   23-08-95   Version 2.0   Author: Laurent Terray
+!    ******   20-06-97   Version 2.2   Mods: add nudum (S. Valcke)
+!             30-03-99   Version 2.3   Mods: add nulgn (S. Valcke)
+!             23-03-01   Version 2.5   Mods: add lncdfxxx (S. Valcke)
+!@
+!@  Contents : unit numbers
+!@  --------
+!@
+!@ -- nulin : logical unit for coupler input
+!@
+!@ -- nulou : logical unit for coupler output
+!@
+!@ -- nulgr : logical unit for gcm's grids
+!@
+!@ -- nulma : logical unit for gcm's masks
+!@
+!@ -- nulsa : logical unit for gcm's surfaces
+!@
+!@ -- nultr : trace file for CLIM and PVM messages
+!@
+!@ -- nulcc : file for ANAISM data
+!@
+!@ -- nulgg : file for ANAISG data
+!@
+!@ -- nulgn : file for NINENN weights and addresses
+!@
+!@ -- nulan : file for ANAIS(M-G) specific output
+!@
+!@ -- nulrd : file for reduced grid masks
+!@
+!@ -- nudum : dummy file signaling that SVIPC pools for exchange of 
+!@            initial infos are OPENED
+!@
+! -------------------------------------------------------------------   
+!
+  USE mod_kinds_oasis
+  INTEGER(kind=ip_intwp_p) ::  nulin, nulou, nulgr, nulma, nulsu, nultr, nulcc 
+  INTEGER(kind=ip_intwp_p) ::  nulgg, nulan, nulrd, nudum, nulgn 
+!
+END MODULE mod_unit
+! -------------------------------------------------------------------   
+
+
+
+
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mod_unitncdf.F90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mod_unitncdf.F90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mod_unitncdf.F90	(revision 1677)
@@ -0,0 +1,51 @@
+MODULE mod_unitncdf
+!
+! -- unitncdf.h: 23-03-01   Version 2.5   Author: S. Valcke 
+!    ********** 
+!@
+!@  Contents : netcdf LOGICAL flags and file ids 
+!@  --------
+!@
+!@ -- nc_grdid: netCDF id for grids.nc file
+!@ -- nc_mskid: netCDF id for masks.nc file
+!@ -- nc_surid: netCDF id for areas.nc file
+!@ -- nc_inpid: netCDF id for input field file
+!@ -- nc_scpid: netCDF id for SCRIP matrix file
+!@ -- nc_outid: netCDF id for output field file
+!@ -- nc_invartimeid: netCDF id for time variable (input file)
+!@
+!@ -- n_reaty: Type of REAL variables
+!@ -- n_intty: Type of INTEGER variables
+!@ -- lncdfgrd : LOGICAL true IF all grid auxilary files are netCDF
+!@ -- lncdfrst : LOGICAL true IF restart auxilary files are netCDF
+!@ -- lncdfana : LOGICAL true IF analysis auxilary files are netCDF  
+!@
+!@ -- rtime_val : time counter as read in interpolation input file
+!     ---------------------------------------------------------------   
+!
+  USE mod_kinds_oasis
+  INTEGER (kind=ip_intwp_p) :: nc_grdid, nc_mskid, nc_surid, n_reaty, n_intty
+  INTEGER (kind=ip_intwp_p) :: nc_scpid
+  INTEGER (kind=ip_intwp_p),DIMENSION(:),ALLOCATABLE ::  nc_inpid, nc_outid 
+  INTEGER (kind=ip_intwp_p) :: nc_invartimeid
+!
+  LOGICAL :: lncdfgrd, lncdfrst, lncdfana
+!
+  REAL(kind=ip_realwp_p) :: rtime_val
+!
+  CHARACTER(len=20) :: nc_invartime_name
+!
+!* ------------------------------------------------------------------   
+!
+END MODULE mod_unitncdf
+!
+!*====================================================================
+
+
+
+
+
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/modsgc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/modsgc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/modsgc.F	(revision 1677)
@@ -0,0 +1,107 @@
+      SUBROUTINE modsgc
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *modsgc*  - Change sigcld handler
+C
+C     Purpose:
+C     -------
+C     Modify sigcld handler before signals are sent for the last time.
+C     Use fsigctl (PIPE-CRAY case) or signal (SIPC case)
+C     calls to change sigcld signal handler.
+C     This is done to avoid a recursive I/O error.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *modsgc*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     fsigctl, signal
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/10/01  modified: new structure
+C       2.2       S. Valcke, L.T 97/11/13  Added: call signal
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      2K/09/04  Remove cmach
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+C
+C* ---------------------------- External declarations -------------------
+C
+      EXTERNAL ferror
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE modsgc  -  Level C'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Change sigcld handler     '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C
+C*    2. Modify sigcld signal handler in PIPE or SIPC case
+C        -------------------------------------------------
+C
+#ifdef use_comm_PIPE
+          CALL fsigctl ('IGNORE','SIGCLD',0)
+#elif defined use_comm_SIPC
+          CALL cldignore
+#endif
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine modsgc ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/mozaic.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/mozaic.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/mozaic.f	(revision 1677)
@@ -0,0 +1,184 @@
+      SUBROUTINE mozaic (pfldn, ksizn, pfldo, ksizo,
+     $                   cdfic, kunit, cdgrd, knumb,
+     $                   pwork, kwork, knbor, ldread)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *mozaic* - Mapping interpolation
+C
+C     Purpose:
+C     -------
+C     Do simple mapping interpolation from a source to a target grid
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *mozaic (pfildn, ksizn, pfildo, ksizo, cdfic, kunit,
+C                        cdgrd. knumb, pwork, kwork, knbor, ldread)*
+C
+C     Input:
+C     -----
+C                pfldo  : field on source grid (real 1D)
+C                ksizn  : size of field array on target grid(integer)
+C                ksizo  : size of field array on source grid(integer)
+C                kunit  : logical unit numbers for mapping file (integer)
+C                cdfic  : filename for mapping data (character)
+C                cdgrd  : locator to read mapping data in cdfic (character)
+C                knumb  : mapping dataset identity number (integer)
+C                pwork  : temporary array to read mapping weights (real 2D)
+C                kwork  : temporary array to read mapping array (integer 2D)
+C                knbor  : maximum number of source grid neighbors with non zero
+C                         intersection with a target grid-square (integer)
+C                ldread : logical flag to read mapping data
+C
+C     Output:
+C     ------
+C                pfldn  : field on target grid (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     locrint
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      96/02/01  created
+C       2.1       L. Terray      96/08/05  modified: Add logical flag to
+C                                          read adresses and weights
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.4       S. Valcke      2K/02/05  corrected for overflow pfldo(0)
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfldn(ksizn), pfldo(ksizo), 
+     $    pwork(knbor,ksizn)
+      INTEGER (kind=ip_intwp_p) kwork(knbor,ksizn)
+      CHARACTER*8 cdfic, cdgrd
+      LOGICAL ldread
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clweight, cladress
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE mozaic  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' grid mapping interpolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* initialize error flag for I/O routine
+C
+      iflag = 0
+C
+C
+C*    2. Read mapping data the first time
+C        --------------------------------
+C
+      IF (ldread) THEN 
+C
+C* Initialize locators and array sizes
+C
+          WRITE(clweight,'(''WEIGHTS'',I1)') knumb
+          WRITE(cladress,'(''ADRESSE'',I1)') knumb
+          isize = ksizn * knbor
+C
+C* Adress of overlapped points on source grid
+C
+          CALL locrint (cladress, kwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading mapping data',
+     $            cdgrd, 1)
+              CALL prcout
+     $            ('Could not get adress array', cladress, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in mozaic') 
+          ENDIF
+C
+C* Weights of overlapped points on source grid
+C
+          CALL locread (clweight, pwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading mapping data',
+     $            cdgrd, 1)
+              CALL prcout
+     $            ('Could not get weight array', clweight, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in mozaic') 
+          ENDIF
+          ldread = .FALSE. 
+      ENDIF 
+C
+C
+C*    3. Do the mapping interpolation
+C        ----------------------------
+C
+C* Loop on all the target grid points
+C
+      DO 310 ji = 1, ksizn
+        zsum = 0.
+        DO 320 jk = 1, knbor
+          IF (kwork(jk,ji) .NE. 0) 
+     $         zsum = zsum + pwork(jk,ji) * pfldo(kwork(jk,ji))
+ 320    CONTINUE 
+        pfldn(ji) = zsum
+ 310  CONTINUE
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine mozaic ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/nextbl.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/nextbl.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/nextbl.f	(revision 1677)
@@ -0,0 +1,82 @@
+      FUNCTION nextbl (cdstr, kistr, knstr)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *nextbl*  - Search function
+C
+C     Purpose:
+C     -------
+C     Find the first blank in a character string
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *nextbl (cdstr, kistr, knstr)*
+C
+C     Input:
+C     -----
+C                cdstr : string to be searched (char string)
+C                kistr : initial search position within the string (integer)
+C                knstr : final search position within the string (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      CHARACTER*1 cdstr
+      DIMENSION cdstr(knstr)
+C
+C* ---------------------------- Local declarations -------------------
+C
+      CHARACTER (len=1), SAVE :: clblank = ' '
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Find first blank character
+C        --------------------------
+C
+      DO 110 ji = kistr, knstr
+        idum = ji
+        IF (cdstr(ji) .EQ. clblank) GO TO 120
+  110 CONTINUE
+  120 CONTINUE
+      nextbl = idum
+      IF (idum .GE. knstr) nextbl = -1
+C
+C
+C*    2. End of function
+C        ---------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/nextch.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/nextch.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/nextch.f	(revision 1677)
@@ -0,0 +1,82 @@
+      FUNCTION nextch (cdstr, kistr, knstr)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *nextch*  - Search function
+C
+C     Purpose:
+C     -------
+C     Find the first non-blank in a character string
+C
+C**   Interface:
+C     ---------
+C       *ii =*  *nextch (cdstr, kistr, knstr)*
+C
+C     Input:
+C     -----
+C                cdstr : string to be searched (char string)
+C                kistr : initial search position within the string (integer)
+C                knstr : final search position within the string (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      CHARACTER*1 cdstr
+      DIMENSION cdstr(knstr)
+C
+C* ---------------------------- Local declarations -------------------
+C
+      CHARACTER (len=1), SAVE :: clblank = ' '
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C
+C*    1. Find the first non-blank character
+C        ----------------------------------
+C
+      DO 110 ji = kistr, knstr
+        idum = ji
+        IF (cdstr(ji) .NE. clblank) GO TO 120
+  110 CONTINUE
+  120 CONTINUE
+      nextch = idum
+      IF (idum .GE. knstr) nextch = -1
+C
+C
+C*    2. End of function
+C        ---------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/parse.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/parse.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/parse.f90	(revision 1677)
@@ -0,0 +1,137 @@
+SUBROUTINE parse (cdone, cdtwo, knumb, klen, kleng)
+  USE mod_kinds_oasis
+!****
+!               *****************************
+!               * OASIS ROUTINE  -  LEVEL T *
+!               * -------------     ------- *
+!               *****************************
+!
+!**** *parse*  - Parsing routine
+!
+!     Purpose:
+!     -------
+!     Find the knumb'th string in cdone and put it in cdtwo.
+!     A string is defined as a continuous set of non-blanks characters
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *parse (cdone, cdtwo, knumb, klen, kleng)*
+!
+!     Input:
+!     -----
+!                cdone : line to be parsed (char string)
+!                knumb : rank within the line of the extracted string (integer)
+!                klen  : length of the input line (integer)
+!
+!     Output:
+!     ------
+!                cdtwo : extracted character string (char string)
+!                kleng : length of the extracted string (integer)
+!
+!     Workspace:
+!     ---------
+!     None
+!
+!     Externals:
+!     ---------
+!
+!     Reference:
+!     ---------
+!     See OASIS manual (1995)
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.0       L. Terray      95/09/01  created
+!                 O. Marti     2000/11/08  simplify by using F90 
+!                                          CHARACTER functions
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!* ---------------------------- Include files ---------------------------
+!
+  USE mod_unit
+!
+!* ---------------------------- Argument declarations -------------------
+!
+  INTEGER (kind=ip_intwp_p), INTENT ( in) :: knumb, klen
+  CHARACTER (len=klen), INTENT ( inout) :: cdone 
+  CHARACTER (len=klen), INTENT ( out) :: cdtwo
+  INTEGER (kind=ip_intwp_p), INTENT ( out) :: kleng
+!
+!* ---------------------------- Local declarations -------------------
+!
+  CHARACTER (len=klen) :: clline
+  CHARACTER (len=klen) :: clwork
+  CHARACTER (len=1), SAVE :: clblank = ' ', clcmt = '#'
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Skip line if it is a comment
+!        ----------------------------
+!
+100 IF (cdone(1:1) .NE. clcmt) GO TO 120
+  READ (UNIT = nulin, FMT = 1001) clline 
+  cdone(1:klen) = clline(1:klen)
+  GO TO 100
+120 CONTINUE 
+1001 FORMAT(A80)
+!
+!
+!*    2. Do the extraction job
+!        ---------------------
+!
+!* - Fill cdtwo with blanks
+!
+  cdtwo = clblank
+!
+!* Fill temporary string and remove leading blanks
+!
+  clwork = ADJUSTL ( cdone)
+!
+!* - If there are no more characters, kleng=-1
+!
+  IF ( LEN_TRIM ( clwork) .LE. 0) THEN
+      kleng = -1
+      RETURN
+  END IF
+!
+!* - If this is the one we're looking for, skip
+!    otherwise go knumb-1 more sets of characters
+!
+  IF (knumb .GE. 2) THEN
+      DO jl = 1, knumb-1
+        ii = INDEX ( clwork, clblank) - 1
+        clwork ( 1:ii) = clblank
+        clwork = ADJUSTL ( clwork)
+!
+!* - If there are no more characters, kleng=-1
+!
+        IF (LEN_TRIM ( clwork) .LE. 0) THEN
+            kleng = -1
+            RETURN
+        END IF
+      END DO
+  END IF
+!
+!* - Find the length of this set of characters
+!
+  kleng = INDEX ( clwork, clblank) - 1
+!
+!* - Copy to cdtwo
+!
+  cdtwo ( 1:kleng) = clwork ( 1: kleng)
+!
+!
+!*    3. End of routine
+!        --------------
+!
+  RETURN
+END SUBROUTINE parse
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/parseblk.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/parseblk.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/parseblk.f90	(revision 1677)
@@ -0,0 +1,146 @@
+SUBROUTINE parseblk (cdone, cdtwo, knumb, klen, kleng)
+  USE mod_kinds_oasis
+!****
+!               *****************************
+!               * OASIS ROUTINE  -  LEVEL T *
+!               * -------------     ------- *
+!               *****************************
+!
+!**** *parse*  - Parsing routine
+!
+!     Purpose:
+!     -------
+!     Get the rest of the line starting at the knumb'th string.
+!     A string is defined as a continuous set of non-blanks characters
+!
+!**   Interface:
+!     ---------
+!       *CALL*  *parseblk (cdone, cdtwo, knumb, klen, kleng)*
+!
+!     Input:
+!     -----
+!                cdone : line to be parsed (char string)
+!                knumb : rank within the line of the starting string (integer)
+!                klen  : length of the input line (integer)
+!
+!     Output:
+!     ------
+!                cdtwo : extracted rest of line, including blanks (char string)
+!                kleng : length of the extracted string (integer)
+!
+!     Workspace:
+!     ---------
+!     None
+!
+!     Externals:
+!     ---------
+!
+!     History:
+!     -------
+!       Version   Programmer     Date      Description
+!       -------   ----------     ----      -----------  
+!       2.5       S. Valcke      00/09/08  Adapted from parse.f
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!* ---------------------------- Include files ---------------------------
+!
+  USE mod_unit
+!
+!* ---------------------------- Argument declarations -------------------
+!
+  INTEGER (kind=ip_intwp_p), INTENT ( in) :: knumb, klen
+  CHARACTER (len=klen), INTENT ( inout) :: cdone
+  CHARACTER (len=klen), INTENT ( out) :: cdtwo
+  INTEGER (kind=ip_intwp_p), INTENT ( out) :: kleng
+!
+!* ---------------------------- Local declarations -------------------
+!
+  INTEGER (kind=ip_intwp_p) :: il, kleng_aux
+  CHARACTER (len=klen) :: clline
+  CHARACTER (len=klen) :: clwork
+  CHARACTER (len=1), SAVE :: clblank = ' ', clcmt = '#'
+!
+!* ---------------------------- Poema verses ----------------------------
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!*    1. Skip line if it is a comment
+!        ----------------------------
+!
+100 IF (cdone(1:1) .NE. clcmt) GO TO 120
+  READ (UNIT = nulin, FMT = 1001) clline 
+  cdone(1:klen) = clline(1:klen)
+  GO TO 100
+120 CONTINUE 
+1001 FORMAT(A80)
+!
+!
+!*    2. Do the extraction job
+!        ---------------------
+!
+!* - Fill cdtwo with blanks
+!
+  cdtwo = clblank
+!
+!* Fill temporary string and remove leading blanks
+!
+  il = INDEX ( cdone, clblank)
+  kleng_aux = 1
+  IF (INDEX ( cdone, clblank).EQ.1) THEN
+      DO WHILE (cdone(il+1:il+1).EQ.clblank)
+        kleng_aux = kleng_aux +1
+        il = il+1
+        IF (il+1.GT.klen) GO TO 130
+      ENDDO
+  ENDIF
+130 CONTINUE
+  clwork = ADJUSTL ( cdone)
+!
+!* - If there are no more characters, kleng=-1
+!
+  IF ( LEN_TRIM ( clwork) .LE. 0) THEN
+      kleng = -1
+      RETURN
+  END IF
+!
+!* - If this is the one we're looking for, skip
+!    otherwise go knumb-1 more sets of characters
+!
+  IF (knumb .GE. 2) THEN
+      DO jl = 1, knumb-1
+        ii = INDEX ( clwork, clblank) - 1
+        il = ii + 1 
+        DO WHILE (clwork(il:il).EQ.clblank)
+          kleng_aux = kleng_aux +1
+          il = il + 1
+          IF (il.GT.klen) GO TO 140
+        ENDDO
+140 CONTINUE
+        kleng_aux = kleng_aux + ii
+        clwork ( 1:ii) = clblank
+        clwork = ADJUSTL ( clwork)
+!
+!* - If there are no more characters, kleng=-1
+!
+        IF (LEN_TRIM ( clwork) .LE. 0) THEN
+            kleng = -1
+            RETURN
+        END IF
+      END DO
+  END IF
+!
+!* - Find the length of the rest of the line
+!
+  kleng = klen - kleng_aux
+!
+!* - Copy to cdtwo
+!
+  cdtwo ( 1:kleng) = clwork ( 1: kleng)
+!
+!*    3. End of routine
+!        --------------
+!
+  RETURN
+END SUBROUTINE parseblk
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/postpro.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/postpro.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/postpro.f	(revision 1677)
@@ -0,0 +1,230 @@
+      SUBROUTINE postpro (kindex, kfield)
+      USE mod_kinds_oasis
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *postpro* - postprocessing routine
+C
+C
+C     Purpose:
+C     -------
+C     Do the field postprocessing
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *postpro (kindex, kfield)*
+C
+C     Input:
+C     -----
+C                kindex : current active fields index array
+C                kfield : current active fields total number
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     reverse, revmsk, masq, extrap, glored, chkfld
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.1       L. Terray      96/09/25  modified: call to chkfld and
+C                                          addition of amskred
+C       2.2       L. Terray      97/12/31  modified: call to extrap
+C       2.3       L. Terray      99/03/01  modified: call to extrap
+C       2.3       S. Valcke      99/04/15  modified: CALL to extrap
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C       2.3       S. Valcke      99/10/14  CALL to extrap corrected
+C       2.5       S. Valcke      00/09/05  Changed iintflx for itoutflx 
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_parameter
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_extrapol
+      USE mod_unit
+      USE mod_gauss
+      USE mod_label
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clxordaf, clyordaf, clextmet, clname, clper
+      CHARACTER*32 clabel
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE postpro  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Postprocessing of coupling fields'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C
+C*    2. Do the job
+C        ----------
+C
+!$omp parallel do default (shared)
+!$omp+ private (jf,ifield,iadrnew,iadrnew_grid)
+!$omp+ private (isiznew,clname,clyordaf)
+!$omp+ private (ilabel,clabel,ilonaf,ilataf,clxordaf)
+!$omp+ private (itoutflx,ja,ji,clextmet,clper)
+!$omp+ private (itronca,ineibor,iper)
+
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+        ifield = kindex(jf)
+        iadrnew = nadrnew(ifield)
+        iadrnew_grid = nadrnew_grid(ifield)
+        isiznew = nsiznew(ifield)
+        clname = cnamout(ifield)
+        ilabel = numlab(ifield)
+        clabel = cfldlab(ilabel)
+        ilonaf = nlonaf(ifield)
+        ilataf = nlataf(ifield)
+        clxordaf = cxordaf(ifield)
+        clyordaf = cyordaf(ifield)
+        itoutflx = ntoutflx(ifield)
+C
+C* Print field name
+C
+        IF (nlogprt .GE. 1) THEN
+            CALL prcout('Treatment of field : ', clname, 2)
+        ENDIF
+C
+C* - Do postprocessing analysis
+C
+        DO 220 ja = 1, ig_ntrans(ifield)
+C
+C* --->>> MaskP
+C
+          IF (canal(ja,ifield) .EQ. 'MASKP') THEN 
+            
+              CALL masq(fldnew(iadrnew), isiznew, amskvalnew(ifield),
+     $                      msknew(iadrnew_grid))
+C
+C* --->>> Reverse
+C
+          ELSE IF (canal(ja,ifield) .EQ. 'REVERSE') THEN 
+              CALL reverse (fldnew(iadrnew), ilonaf,
+     $                      ilataf, clxordaf, clyordaf)
+C
+C* --->>> Checkout: perform basic checks on the field to be exported
+C
+          ELSE IF (canal(ja,ifield) .EQ. 'CHECKOUT') THEN
+              CALL chkfld(clname, clabel, 
+     $            fldnew(iadrnew), msknew(iadrnew_grid), 
+     $            surnew(iadrnew_grid),
+     $            isiznew, ilonaf, itoutflx)
+C
+C* --->>> Glored
+C
+          ELSE IF (canal(ja,ifield) .EQ. 'GLORED') THEN
+C
+C* Do extrapolation on full grid to assign sea values to land points
+C
+C* - First we mask the field
+C    We use a predefined value for the mask
+C    If necessary, we reorder the mask as the field might have been already
+C    reversed ( while array msknew is ordered along OASIS conventions). 
+C
+C* Put mask in work array
+C
+              CALL izero (nwork, ig_nwork)
+              DO 230 ji = 1, isiznew
+                nwork(ji) = msknew(iadrnew_grid + ji -1)
+ 230          CONTINUE 
+C
+C* Reverse mask if necessary
+C
+              CALL revmsk (nwork(1), ilonaf, ilataf,
+     $            clxordaf, clyordaf)
+              zmskval = amskred
+              CALL masq (fldnew(iadrnew), isiznew, zmskval,
+     $            nwork(1))
+C
+C* - Then we extrapolate
+C    We use predefined values for extrapolation parameters
+C
+              clextmet = 'NINENN'
+              ineibor = neighborg(ifield)
+C
+C* Grid periodicity
+C
+              clper = ctper(ifield)
+              iper = notper(ifield)
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+C
+C* Do it now
+C
+              CALL extrap (fldnew(iadrnew), zmskval, work(1), 
+     $            nwork(1), ilonaf, ilataf,
+     $            ineibor, clextmet, clper, iper,
+     $            niwtng(ifield), nninnflg(ifield))
+C
+C* Do the interpolation full to reduced gaussian grid
+C
+              itronca = ntronca(ifield)
+              CALL szero (work, ig_work)
+              CALL glored (fldnew(iadrnew), work(1),
+     $                     ilonaf, ilataf, itronca)
+          ELSE
+              CONTINUE
+          END IF
+ 220    CONTINUE
+ 210  CONTINUE 
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine postpro ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/prcout.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/prcout.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/prcout.f	(revision 1677)
@@ -0,0 +1,96 @@
+      SUBROUTINE prcout (cdtext, cdstring, kstyle)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *prcout*  - Print output
+C
+C     Purpose:
+C     -------
+C     Print out character string and one character value
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *prcout (cdtext, cdstring, kstyle)*
+C
+C     Input:
+C     -----
+C                cdtext   : character string to be printed
+C                cdstring : character variable to be printed
+C                kstyle   : printing style
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       L. Terray      99/02/24  modified: X format for NEC
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations ----------------------
+C
+      CHARACTER*(*) cdtext, cdstring
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER cpbase
+      CHARACTER*10 cprpt, cpdots
+      CHARACTER*69 cline
+      PARAMETER ( cpbase = '-' )
+      PARAMETER ( cprpt = '* ===>>> :' )
+      PARAMETER ( cpdots = '  ------  ' )
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Print character string + character value
+C        ----------------------------------------
+C
+      IF ( kstyle .EQ. 1 .OR. kstyle .EQ. 2) THEN
+          cline = ' '
+          ilen = len(cdtext)
+          DO 110 jl = 1, ilen
+            cline(jl:jl) = cpbase
+ 110      CONTINUE
+          IF ( kstyle .EQ. 2 ) THEN
+              WRITE(UNIT = nulou,FMT='(/,A,1X,A)') cpdots, cline
+          ENDIF
+          WRITE(UNIT = nulou,FMT='(A,1X,A,1X,A)') 
+     $        cprpt, cdtext, cdstring
+          WRITE(UNIT = nulou,FMT='(A,1X,A,/)') cpdots, cline
+        ELSE
+          WRITE(UNIT = nulou,FMT='(/,A,1X,A,1X,A,/)') 
+     $          cprpt, cdtext, cdstring
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      CALL FLUSH (nulou)
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/preproc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/preproc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/preproc.F	(revision 1677)
@@ -0,0 +1,360 @@
+      SUBROUTINE preproc (kindex, kfield)
+      USE mod_kinds_oasis
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *preproc* - preprocess routine
+C
+C
+C     Purpose:
+C     -------
+C     Do the field preprocessing
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *preproc (kindex, kfield)*
+C
+C     Input:
+C     -----
+C                kindex : field identificator array (integer 1D)
+C                kfield : number of fields for current iteration (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C                zcocoef : additional field coefficients for correct (real 1D)
+C                inip    : array for reduced grid data for redglo (integer 1D)
+C                clcofld : additional field names for correct (character 1D)
+C                clcofic : array to handle data file names (character 1D)
+C                iunit   : array to handle I/O units of data files (integer 1D)
+C
+C     Externals:
+C     ---------
+C     correct, extrap, extraw, invert, masq, redglo, chkfld
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1998)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C       2.1       L. Terray      96/09/25  modified: Call to chkfld
+C       2.2       L. Terray      97/12/16  Added: new extrapolation
+C                                          and change call to extrap
+C       2.3       L. Terray      99/03/01  modified: call to extrap
+C       2.3       S. Valcke      99/03/16  modified for T213 and T319
+C       2.3       S. Valcke      99/03/16  modified for T213 and T319
+C       2.3       S. Valcke      99/03/26  changed troncature for number of 
+C                                          latitude between equator and pole
+C       2.3       S. Valcke      99/03/30  changed arguments in CALL to extrap
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  changed periodicity variables
+C       2.5       S. Valcke      00/09/05  Changed iintflx for itinpflx 
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* -----------------Include files and USE of modules---------------------------
+C
+      USE mod_parameter
+      USE mod_string
+      USE mod_analysis
+      USE mod_memory
+      USE mod_extrapol
+      USE mod_unit
+      USE mod_gauss
+      USE mod_label
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kindex(kfield)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) inip(320)
+      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iunit
+      REAL (kind=ip_realwp_p),DIMENSION(:), ALLOCATABLE :: zcocoef
+      CHARACTER*8 clxordbf, clyordbf, clextmet, clname, clmsk, clper
+      CHARACTER*8 clfic, clstrg
+      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clcofic, clcofld
+      CHARACTER*32 clabel
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization and allocation of local arrays
+C        ---------------------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE preproc  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Preprocessing of coupling fields'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+      ALLOCATE (iunit(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "iunit" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (zcocoef(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "zcocoef" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (clcofic(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "clcofic" allocation of 
+     $    cookart ',il_err,1)
+      ALLOCATE (clcofld(ig_maxcomb),stat=il_err)
+      IF (il_err.NE.0) CALL prtout ('Error in "clcofld" allocation of 
+     $    cookart ',il_err,1)
+      iunit(:)=0
+      zcocoef(:)=0
+      clcofic(:)=' '
+      clcofld(:)=' '
+C
+C* Zeroes work array
+C
+      CALL szero (work,ig_work)
+      CALL izero (nwork,ig_nwork)
+C
+C
+C*    2. Do the job
+C        ----------
+!$omp parallel do default (shared)
+!$omp+ private (ja,jf,ji,jc)
+!$omp+ private (ifield,clname,ilataf)
+!$omp+ private (clabel,clextmet,ineibor)
+!$omp+ private (ipdeb,ilatbf,ilonbf)
+!$omp+ private (iadrold,iadrold_grid,isizold)
+!$omp+ private (clfic,ilun,clper)
+!$omp+ private (clstrg,ilabel)
+!$omp+ private (iloc,clintmet,clgrdtyp,clfldtyp)
+!$omp+ private (icofld)
+!$omp+ private (clfilfic,itinpflx,zfldcoef)
+!$omp+ private (iper,itronca,clmsk,iredu)
+!$omp+ private (zmskval,clxordbf,clyordbf)
+
+C
+      DO 210 jf = 1, kfield
+C
+C* Assign local variables
+C
+        ifield = kindex(jf)
+        ilabel = numlab(ifield)
+        clname = cnaminp(ifield)
+        clabel = cfldlab(ilabel)
+        iadrold = nadrold(ifield)
+        iadrold_grid = nadrold_grid(ifield)
+        isizold = nsizold(ifield)
+        ilonbf = nlonbf(ifield)
+        ilatbf = nlatbf(ifield)
+        itinpflx = ntinpflx(ifield)
+C
+C* Print field name
+C
+        IF (nlogprt .GE. 1) THEN
+            CALL prcout('Treatment of field :', clname, 2)
+        ENDIF
+C
+C* - Do preprocessing analysis
+C
+        DO 220 ja = 1, ig_ntrans(ifield)
+          IF (canal(ja,ifield) .EQ. 'MASK') THEN
+C
+C* --->>> Mask
+C
+              zmskval = amskval(ifield)
+!$omp critical
+              CALL masq (fldold(iadrold), isizold, zmskval,
+     $                   mskold(iadrold_grid))
+!$omp end critical
+C
+C* --->>> Invert
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'INVERT') THEN 
+              clxordbf = cxordbf(ifield)
+              clyordbf = cyordbf(ifield)
+              CALL invert (fldold(iadrold), ilonbf,
+     $                     ilatbf, clxordbf, clyordbf)
+C
+C* --->>> Checkin: perform basic checks on input field
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'CHECKIN') THEN 
+              CALL chkfld(clname, clabel, 
+     $            fldold(iadrold), mskold(iadrold_grid), 
+     $              surold(iadrold_grid),
+     $            isizold, ilonbf, itinpflx)
+C
+C* --->>> Flux correction
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'CORRECT') THEN
+C
+C* Assign local variables to main field coefficient
+C
+              zfldcoef = afldcoef(ifield)
+C
+C* Get loop index to read additional fields, coefficients, filenames
+C  and related logical units
+C
+              icofld = ncofld(ifield)
+              DO 230 jc = 1, icofld
+                clcofld(jc) = ccofld(jc,ifield)
+                zcocoef(jc) = acocoef(jc,ifield)
+                clcofic(jc) = ccofic(jc,ifield)
+                iunit(jc)   = nludat(jc,ifield)
+ 230          CONTINUE
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+C
+C* Do the job
+C 
+              CALL correct (fldold(iadrold), isizold,
+     $                      zfldcoef, icofld, zcocoef(1),
+     $                      work(1), iunit(1), clcofic(1), 
+     $                      clcofld(1))
+C
+C* --->>> Extrap
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'EXTRAP') THEN
+              clextmet = cextmet(ifield)
+              ineibor = neighbor(ifield)
+C
+C* 8-nearest neighbors extrapolation
+C
+              IF (clextmet .EQ. 'NINENN') THEN 
+                  zmskval = amskval(ifield)
+                  clper = csper(ifield)
+                  iper = nosper(ifield)
+C
+C* Zero work array
+C
+                  CALL szero (work, ig_work)
+C
+C* Do it now
+C
+#ifdef key_openmp
+                  niwtn=0
+#endif
+!$omp critical
+                  CALL extrap (fldold(iadrold), zmskval, work(1),
+     $                         mskold(iadrold_grid), ilonbf, ilatbf, 
+     $                         ineibor, clextmet, clper, iper,  
+     $                         niwtn(ifield), nninnfl(ifield))
+C
+!$omp end critical
+C* N-weighted neighbors extrapolation
+C
+              ELSE IF (clextmet .EQ. 'WEIGHT') THEN 
+                  clfic = cgrdext(ifield)
+                  ilun  = nluext(ifield)
+                  iloc  = nextfl(ifield)
+                  clstrg = cficbf(ifield)//cficbf(ifield)
+                  ipdeb = (nextfl(ifield)-1)*ig_maxext*ig_maxgrd+1
+C
+C* Do it now
+C
+                  CALL extraw (fldold(iadrold), mskold(iadrold_grid),
+     $                isizold, clfic, ilun, clstrg, iloc,  
+     $                aextra(ipdeb), nextra(ipdeb), ineibor,
+     $                lextra(ifield))
+              ENDIF 
+              lextrapdone(ifield) = .true.
+C
+C* --->>> Redglo
+C
+            ELSE IF (canal(ja,ifield) .EQ. 'REDGLO') THEN
+              itronca = ntronca(ifield)
+              clmsk = cmskrd(ifield)
+              zmskval = amskred
+C
+C* get number of longitudes by latitude circle and total number of points
+C  reduced grid
+C
+C* Zero work array
+C
+              CALL szero (work, ig_work)
+              CALL izero (nwork, ig_nwork)
+              CALL izero (inip, 320)
+              IF (itronca .EQ. 16) THEN
+                  DO 240 ji = 1, itronca
+                    inip(ji) = ninip16(ji)
+ 240              CONTINUE
+                  iredu = nredu16
+                ELSE IF (itronca .EQ. 24)  THEN 
+                  DO 250 ji = 1, itronca
+                    inip(ji) = ninip24(ji)
+ 250              CONTINUE 
+                  iredu = nredu24
+                ELSE IF (itronca .EQ. 32)  THEN 
+                  DO 260 ji = 1, itronca
+                    inip(ji) = ninip32(ji)
+ 260              CONTINUE 
+                  iredu = nredu32
+                ELSE IF (itronca .EQ. 48)  THEN 
+                  DO 270 ji = 1, itronca
+                    inip(ji) = ninip48(ji)
+ 270              CONTINUE
+                   iredu = nredu48   
+                ELSE IF (itronca .EQ. 80)  THEN 
+                  DO 280 ji = 1, itronca 
+                    inip(ji) = ninip80(ji)
+ 280              CONTINUE
+                  iredu = nredu80
+                ELSE IF (itronca .EQ. 160)  THEN 
+                  DO 285 ji = 1, itronca
+                    inip(ji) = ninip160(ji)
+ 285              CONTINUE
+                  iredu = nredu160
+                ELSE
+                  CALL prtout
+     $          ('WARNING!!! Oasis cannot treat this grid with 2*NO 
+     $          latitude lines with NO = ', itronca, 2)
+                  CALL prtout
+     $                ('Implement data for NO =', itronca, 2)
+                  CALL HALTE('STOP in preproc')
+              ENDIF
+              DO 290 ji = ilatbf/2 + 1, ilatbf
+                inip(ji) = inip(ilatbf - ji + 1)
+ 290          CONTINUE
+              CALL redglo (fldold(iadrold), work(1), iredu, inip,
+     $                     ilonbf, ilatbf, nwork(1), nwork(1+iredu),
+     $                     itronca, zmskval, clmsk)
+            ELSE
+              CONTINUE 
+          END IF
+ 220      CONTINUE
+ 210    CONTINUE 
+C
+C
+C*    3. Deallocation and end of routine
+C        -------------------------------
+C
+        DEALLOCATE(iunit)
+        DEALLOCATE(zcocoef)
+        DEALLOCATE(clcofic)
+        DEALLOCATE(clcofld)
+C
+      IF (nlogprt .GE. 1) THEN 
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine preproc ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/prtout.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/prtout.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/prtout.f	(revision 1677)
@@ -0,0 +1,97 @@
+      SUBROUTINE prtout (cdtext, kvalue, kstyle)
+      USE mod_kinds_oasis
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *prtout*  - Print output
+C
+C     Purpose:
+C     -------
+C     Print out character string and one integer value
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *prtout (cdtext, kvalue, kstyle)*
+C
+C     Input:
+C     -----
+C                cdtext : character string to be printed
+C                kvalue : integer variable to be printed
+C                kstyle : printing style
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/01  created
+C       2.3       L. Terray      99/02/24  modified: X format for NEC
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations ----------------------
+C
+      CHARACTER*(*) cdtext
+      INTEGER (kind=ip_intwp_p) kvalue, kstyle
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER cbase
+      CHARACTER*10 cprpt, cdots
+      CHARACTER*69 cline
+      PARAMETER ( cbase = '-' )
+      PARAMETER ( cprpt = '* ===>>> :' )
+      PARAMETER ( cdots = '  ------  ' )
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Print character string + integer value
+C        --------------------------------------
+C
+      IF ( kstyle .EQ. 1 .OR. kstyle .EQ. 2) THEN
+          cline = ' '
+          ilen = len(cdtext)
+          DO 110 jl = 1, ilen
+            cline(jl:jl) = cbase
+ 110      CONTINUE
+          IF ( kstyle .EQ. 2 ) THEN
+              WRITE(UNIT = nulou,FMT='(/,A,1X,A)') cdots, cline
+          ENDIF
+          WRITE(UNIT = nulou,FMT='(A,1X,A,1X,I18)') 
+     $        cprpt, cdtext, kvalue
+          WRITE(UNIT = nulou,FMT='(A,1X,A,/)') cdots, cline
+        ELSE
+          WRITE(UNIT = nulou,FMT='(/,A,1X,A,1X,I18,/)') 
+     $          cprpt, cdtext, kvalue
+      ENDIF
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      CALL FLUSH ( nulou )
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/redglo.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/redglo.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/redglo.f	(revision 1677)
@@ -0,0 +1,321 @@
+      SUBROUTINE redglo 
+     $    (pzgg, pzgr, kredu, kinip, klon, klat, 
+     $     kmask, kland, ktronca, pmask, cdmsk)
+C*****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *redglo* - Global gaussian grid transformation: reduced --> full grid
+C
+C     Purpose:
+C     -------
+C     Linear interpolation of field on reduced grid to full grid 
+C
+C     ***NOTE***
+C     ----------
+C     The flag cdmsk asks for extrapolation or not on the reduced
+C     gaussian grid. If cdmsk  = SEALAND sea values are extended
+C     to continental areas using the reduced grid sea-land mask.
+C     If cdmsk = LANDSEA, the opposite is performed. If cdmsk = 
+C     NOEXTRAP, THEN no extrapolation is performed.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *redglo (pzgg, pzgr, kredu, kinip, klon, klat,
+C                        kmask, kland, ktronca, pmask)
+C
+C     Input:
+C     -----
+C                pzgg    : field on reduced grid (real 2D)
+C                kredu   : number of points on reduced grid
+C                kinip   : number of longitudes per latitude value (integer 1D)
+C                klon    : number of longitudes of global grid
+C                klat    : number of latitudes of both grids
+C                pmask   : reduced grid mask value
+C                ktronca : truncature of gaussian grid
+C                cdmsk   : extrapolation flag
+C  
+C     Output:
+C     ------
+C                pzgg    : field on global grid  (real 2D)
+C                kmask   : mask on reduced grid (integer 1D)
+C
+C     Workspace:
+C     ---------
+C                pzgr    : work array to store field on reduced grid (real 1D)
+C                kland   : number of masked points per latitude circle on
+C                          reduced grid (integer 1D)
+C
+C     External:
+C     --------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/10/10  modified: new structure
+C       2.1       L. Terray      95/11/11  modified: choice of extrapolation
+C       2.3       S. Valcke      99/03/29  modified: error message for maskr
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.5       S. Valcke      01/03/23  added: nulrd opening
+C       2.5       S. Valcke      01/03/23  added: netCDF maskr files
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_unitncdf
+      USE mod_unit
+      USE mod_gauss
+      USE mod_printing
+      USE mod_label
+      INCLUDE 'netcdf.inc'
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pzgg(klon,klat), pzgr(klon*klat)
+      INTEGER (kind=ip_intwp_p) kmask(kredu), kland(klat), kinip(klat)
+      CHARACTER*8 cdmsk
+C
+C* ---------------------------- Local declarations -------------------
+C
+      CHARACTER*8 clname
+      INTEGER (kind=ip_intwp_p) il_ncid, il_varid
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE redglo  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Go from reduced to global gaussian grid'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      iflag = 0
+C
+C* Zeroes work array
+C
+      CALL szero(pzgr,klon*klat)
+C
+C* Zeroes some argument arrays
+C
+      CALL izero(kmask,kredu)
+      CALL izero(kland,klat)
+      zmask = pmask - 1.0
+C
+C* Open and READ in reduced gaussian grid maskr file
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '   opening the reduced gaussian grid mask file '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      WRITE(clname,'(''MSKRD'',I3.3)') ktronca
+      IF (lncdfgrd) THEN
+        istatus=NF_OPEN(crednam//'.nc', NF_NOWRITE, il_ncid)
+        IF (istatus .NE. NF_NOERR) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $       ' ===>>>> : error in opening maskr.nc. We STOP!'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE('STOP in redglo')   
+        ENDIF
+C
+        istatus=NF_INQ_VARID(il_ncid, clname, il_varid)
+        istatus=NF_GET_VARA_INT (il_ncid, il_varid, 1, kredu, kmask)
+        IF (istatus .ne. NF_NOERR) THEN
+            WRITE (UNIT = nulou,FMT = *) 
+     $       ' ===>>>> : error in reading variable', clname
+            WRITE (UNIT = nulou,FMT = *)  
+     $         'in maskr.nc, the reduced grid mask file '
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'Note that since version 2.3, the locator for the'
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'reduced mask has to be MSKRDxxx WHERE xxx' 
+            WRITE (UNIT = nulou,FMT = *) 
+     $            'is half the number of latitude lines.'
+            WRITE (UNIT = nulou,FMT = *) ' '
+            CALL HALTE('STOP in redglo')   
+        ENDIF
+        CALL hdlerr(NF_CLOSE(il_ncid), 'redglo')
+      ELSE
+          iunit = nulrd
+          OPEN (UNIT = nulrd,FILE = crednam,STATUS='UNKNOWN',
+     $      FORM ='UNFORMATTED',ERR = 140,IOSTAT = iost)
+          IF (nlogprt .GE. 1) THEN
+              WRITE (UNIT = nulou,FMT = 1001) nulrd, crednam
+              WRITE (UNIT = nulou,FMT = *) ' '
+          ENDIF
+ 140      CONTINUE
+C* Formats
+C
+ 1001 FORMAT(10X,' open unit = ',I3,'    file ',A8,' ok')
+          IF (iost .ne. 0) THEN
+              WRITE (UNIT = nulou,FMT = *) 
+     $         ' ===>>>> : error in opening maskr, the red-grid file'
+              WRITE (UNIT = nulou,FMT = *) 
+     $         ' =======   =====                  ====='
+              WRITE (UNIT = nulou,FMT = *) 
+     $         ' logical unit ',nulrd,' error number = ',
+     $                     iost
+              WRITE (UNIT = nulou,FMT = *) 
+     $         ' We STOP. Verify the file ', crednam
+              WRITE (UNIT = nulou,FMT = *) ' '
+              CALL HALTE('STOP in redglo')   
+          ENDIF
+C
+          CALL locrint(clname, kmask, kredu, iunit, iflag)
+          IF (iflag .NE. 0) THEN
+              CALL prtout('WARNING: problem in reading unit =', 
+     $            iunit, 2)
+              CALL prcout('Error in reading field linked to string =',
+     $                clname, 1)
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'Note that since version 2.3, the locator for the'
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'reduced mask has to be MSKRDxxx WHERE xxx' 
+              WRITE (UNIT = nulou,FMT = *) 
+     $            'is half the number of latitude lines.'
+              CALL HALTE ('STOP in redglo')
+          ENDIF
+      ENDIF
+C* Assign reduced grid values to array pzgr
+C
+      DO 110 jj = 1, klat
+        DO 120 ji = 1, klon
+          pzgr(klon*(jj-1)+ji) = pzgg(ji,jj)
+ 120    CONTINUE 
+ 110  CONTINUE
+C
+C* Test if extrapolation is required
+C
+      IF (cdmsk .EQ. 'SEALAND' .OR. cdmsk .EQ. 'LANDSEA') THEN 
+C
+C
+C*    2. Check if there is any sea point and mask land points
+C        ----------------------------------------------------
+C
+C* First get number of masked points on each latitude circle
+C
+          indice = 0
+C* Extrapolation of land values from sea values, we set mask equal 1
+          IF (cdmsk .EQ. 'SEALAND') imask = 1
+C* Extrapolation of sea values from land values, we set mask equal 0
+          IF (cdmsk .EQ. 'LANDSEA') imask = 0
+          DO 210 jk = 1, klat
+            DO 220 ji = 1, kinip(jk)
+              IF (kmask(indice + ji) .EQ. imask) THEN
+                  kland(jk) = kland(jk) + 1
+              ENDIF
+ 220        CONTINUE
+            indice = indice + kinip(jk)
+ 210      CONTINUE
+C
+C* Then fill up continental or sea values unless all points are land or sea
+C
+          indice = 0
+          DO 230 jk = 1, klat
+            IF (kland(jk) .EQ. kinip(jk)) GO TO 250
+            DO 240 ji = 1, kinip(jk)
+              IF (kmask(indice + ji) .EQ. imask) 
+     $            pzgr(indice + ji) = pmask
+ 240        CONTINUE
+ 250        indice = indice + kinip(jk)
+ 230      CONTINUE
+C
+C
+C*    3. Assign sea values to land points or land values to sea points
+C        -------------------------------------------------------------
+C
+          indice = 0
+          DO 310 jk = 1, klat
+            IF (kland(jk) .EQ. kinip(jk)) GOTO 315
+            DO 320 ji = 1, kinip(jk)
+              inow = indice + ji
+              IF (pzgr(inow) .GT. zmask) THEN
+                  iinf = indice + 1
+                  isup = indice + kinip(jk)
+                  ieast = inow + 1
+                  iwest = inow - 1
+                  icont = 0
+ 325              CONTINUE
+                  IF (ieast .GT. isup) ieast = ieast - kinip(jk)
+                  IF (iwest .LT. iinf) iwest = iwest + kinip(jk)
+                  IF (pzgr(ieast) .LT. zmask .and.
+     $                pzgr(iwest) .LT. zmask) THEN
+                      pzgr(inow) = (pzgr(ieast) + pzgr(iwest))/2.
+                  ELSEIF (pzgr(ieast) .GT. zmask .and.
+     $                    pzgr(iwest) .LT. zmask) THEN
+                      pzgr(inow) = pzgr(iwest)
+                  ELSEIF (pzgr(ieast) .LT. zmask .and.
+     $                    pzgr(iwest) .GT. zmask) THEN
+                      pzgr(inow) = pzgr(ieast)
+                  ELSE
+                      icont = icont + 1
+                      ieast = ieast + 1
+                      iwest = iwest - 1
+                      if (icont .GT. kinip(jk)) 
+     $                    CALL HALTE ('STOP in redglo')
+                      GOTO 325
+                  ENDIF
+              ENDIF
+ 320        CONTINUE
+ 315        indice = indice + kinip(jk)
+ 310      CONTINUE
+C* No extrapolation case
+        ELSE IF (cdmsk .EQ. 'NOEXTRAP') THEN
+          CONTINUE 
+      ENDIF 
+C
+C
+C*    2. Reduced to full linear interpolation  
+C        ------------------------------------
+C
+C* Interpolate from reduced to global
+C 
+      indice = 0
+      DO 270 jk = 1, klat
+        DO 280 ji = 1, klon
+          zxi = 1 + ((ji - 1) * kinip(jk)) / FLOAT(klon)
+          im = INT(zxi)
+          zdx = zxi - im
+          im = 1 + MOD(im + kinip(jk) - 1,kinip(jk))
+          ip = 1 + MOD(im,kinip(jk))
+          pzgg(ji,jk) = pzgr(indice + im) * (1.-zdx) 
+     $                + pzgr(indice + ip) * zdx
+ 280    CONTINUE
+        indice = indice + kinip(jk)
+ 270  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine redglo ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/reset.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/reset.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/reset.f	(revision 1677)
@@ -0,0 +1,95 @@
+      SUBROUTINE reset
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *reset*  - Reinitialize field macro arrays
+C
+C     Purpose:
+C     -------
+C     Zero field macro array
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *reset*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     none
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/08/23  created 
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* --------------- Include files and USE of modules ---------------------------
+C
+      USE mod_parameter
+      USE mod_memory
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Set up memory dynamic allocation
+C        --------------------------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE reset  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           *************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' reinitialize field macro arrays'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* Zero main storage area
+C
+C* - Real arrays: field macro array
+C
+      CALL szero (fldold, ig_maxold)
+      CALL szero (fldnew, ig_maxnew)
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine reset ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/reverse.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/reverse.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/reverse.f	(revision 1677)
@@ -0,0 +1,132 @@
+      SUBROUTINE reverse (pfild ,kxlon ,kylat, cdxord, cdyord)
+      USE mod_kinds_oasis
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *reverse* - Ordering routine
+C
+C     Purpose:
+C     -------
+C     Reorder field according to cdxord and cdyord information
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *reverse (pfild ,kxlon ,kylat, cdxord, cdyord)*
+C
+C     Input:
+C     -----
+C                pfild : field to be reordered (real 2D)
+C                kxlon : number of longitudes
+C                kylat : number of latitudes
+C                cdxord : latitude ordering
+C                cdyord : longitude ordering
+C
+C     Output:
+C     ------
+C                pfild : field reordered (real 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/10/10  modified; new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfild(kxlon,kylat)
+      CHARACTER*8 cdxord, cdyord
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      LOGICAL llxord, llyord
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE reverse  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Reorder field North ---> South '
+          WRITE (UNIT = nulou,FMT = *) ' and from Greenwhich ---> West '
+          WRITE (UNIT = nulou,FMT = *) ' if necessary '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      llxord = cdxord .EQ. 'SUDNOR'
+      llyord = cdyord .EQ. 'WSTEST'
+C
+C
+C*    2. Reorder field 
+C        -------------
+C* South-North buisness
+C
+      IF ( .NOT. llxord) THEN
+          ijmed = kylat/2 
+          DO 210 jj = 1, ijmed
+            DO 220 ji = 1, kxlon
+              zfild = pfild(ji,kylat + 1 - jj)
+              pfild(ji,kylat + 1 - jj) = pfild(ji,jj)
+              pfild(ji,jj) = zfild
+ 220        CONTINUE
+ 210      CONTINUE
+      ENDIF 
+C
+C* East-West one
+C
+      IF ( .NOT. llyord) THEN
+          iimed = kxlon/2 
+          DO 230 jj = 1, kylat
+            DO 240 ji = 1, iimed
+              zfild = pfild(kxlon + 1 - ji,jj)
+              pfild(kxlon + 1 - ji,jj) = pfild(ji,jj)
+              pfild(ji,jj) = zfild
+ 240        CONTINUE
+ 230      CONTINUE
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine reverse ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/revmsk.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/revmsk.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/revmsk.f	(revision 1677)
@@ -0,0 +1,133 @@
+      SUBROUTINE revmsk (kfild ,kxlon ,kylat, cdxord, cdyord)
+      USE mod_kinds_oasis
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *revmsk* - Ordering routine
+C
+C     Purpose:
+C     -------
+C     Reorder integer field according to cdxord and cdyord information
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *revmsk (kfild ,kxlon ,kylat, cdxord, cdyord)*
+C
+C     Input:
+C     -----
+C                kfild : field to be reordered (integer 2D)
+C                kxlon : number of longitudes
+C                kylat : number of latitudes
+C                cdxord : longitude ordering
+C                cdyord : latitude ordering
+C
+C     Output:
+C     ------
+C                kfild : field reordered (integer 2D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/10/10  created
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      INTEGER (kind=ip_intwp_p) kfild(kxlon,kylat)
+      CHARACTER*8 cdxord, cdyord
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      LOGICAL llxord, llyord
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE revmsk     Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Reorder mask field North ---> South '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '      and from Greenwhich ---> West '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' if necessary for glored analysis'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      llxord = cdxord .EQ. 'SUDNOR'
+      llyord = cdyord .EQ. 'WSTEST'
+C
+C
+C*    2. Reorder field 
+C        -------------
+C* South-North buisness
+C
+      IF ( .NOT. llxord) THEN
+          ijmed = kylat/2 
+          DO 210 jj = 1, ijmed
+            DO 220 ji = 1, kxlon
+              ifild = kfild(ji,kylat + 1 - jj)
+              kfild(ji,kylat + 1 - jj) = kfild(ji,jj)
+              kfild(ji,jj) = ifild
+ 220        CONTINUE
+ 210      CONTINUE
+      ENDIF 
+C
+C* East-West one
+C
+      IF ( .NOT. llyord) THEN
+          iimed = kxlon/2 
+          DO 230 jj = 1, kylat
+            DO 240 ji = 1, iimed
+              ifild = kfild(kxlon + 1 - ji,jj)
+              kfild(kxlon + 1 - ji,jj) = kfild(ji,jj)
+              kfild(ji,jj) = ifild
+ 240        CONTINUE
+ 230      CONTINUE
+      ENDIF
+C
+C
+C*    3. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine revmsk ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/rmaxim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/rmaxim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/rmaxim.f	(revision 1677)
@@ -0,0 +1,130 @@
+      FUNCTION rmaxim (pa, kmsk, kna, kind, kflag)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *rmaxim*  - Search function
+C
+C     Purpose:
+C     -------
+C     Search the maximum of the elements of a real array subject
+C     or not to a mask condition
+C
+C**   Interface:
+C     ---------
+C       *zz =*  *rmaxim (pa, kmsk, kna, kind, kflag)*
+C
+C     Input:
+C     -----
+C                pa     : array to be searched (real 1D)
+C                kmsk   : mask array (integer 1D)
+C                kna    : array dimension (integer)
+C                kflag  : type of search (integer)
+C                         0 --> Global  1 --> Land  2 --> Sea
+C
+C     Output:
+C     ------
+C                kind   : point index of maximum
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.1       L. Terray      96/09/25  created
+C       2.2       L. Terray      97/02/12  modified: printing bug on 
+C                                          variable kind corrected
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) rmaxim, pa(kna)
+      INTEGER (kind=ip_intwp_p) kmsk(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the maximum 
+C        ----------------
+C
+      itemp = 0
+      ztemp = 0.0
+      IF (kna .LT. 1) GO TO 110
+ 130  itemp = itemp + 1
+      IF (itemp .GT. kna) THEN
+          CALL prtout
+     $        ('WARNING!!! initial search exceeds array size 
+     $        kna  = ', kna, 2)
+          GO TO 140
+      ENDIF 
+      IF (kflag .EQ. 0) THEN
+          ztemp = pa(itemp)
+          GO TO 140
+        ELSE IF (kflag .EQ. 1) THEN
+          IF (kmsk(itemp) .EQ. 1) THEN 
+              ztemp = pa(itemp)
+              GO TO 140
+          ENDIF 
+        ELSE IF (kflag .EQ. 2) THEN
+          IF (kmsk(itemp) .EQ. 0) THEN 
+              ztemp = pa(itemp)
+              GO TO 140
+          ENDIF
+      ENDIF 
+      GO TO 130
+ 140  CONTINUE 
+C* Assign index to initial point
+      kind = itemp
+C* Start looping on all other points
+      IF (kna .LT. 2) GO TO 110
+        IF (kflag .EQ. 1) THEN 
+	  DO 120 ja = itemp+1, kna
+            IF (pa(ja) .GT. ztemp .AND. kmsk(ja) .EQ. 1) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF
+ 120      CONTINUE
+        ELSE IF (kflag .EQ. 2) THEN 
+	  DO 125 ja = itemp+1, kna
+            IF (pa(ja) .GT. ztemp .AND. kmsk(ja) .EQ. 0) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF
+ 125      CONTINUE
+        ELSE IF (kflag .EQ. 0) THEN 
+	  DO 127 ja = itemp+1, kna
+            IF (pa(ja) .GT. ztemp) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF
+ 127      CONTINUE
+        ENDIF 
+ 110  CONTINUE
+      rmaxim = ztemp
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/rminim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/rminim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/rminim.f	(revision 1677)
@@ -0,0 +1,131 @@
+      FUNCTION rminim (pa, kmsk, kna, kind, kflag)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *rminim*  - Search function
+C
+C     Purpose:
+C     -------
+C     Search the minimum of the elements of a real array subject
+C     or not to a mask condition
+C
+C**   Interface:
+C     ---------
+C       *zz =*  *rminim (pa, kmsk, kna, kind, kflag)*
+C
+C     Input:
+C     -----
+C                pa     : array to be searched (real 1D)
+C                kmsk   : mask array (integer 1D)
+C                kna    : array dimension (integer)
+
+C                kflag  : type of search (integer)
+C                         0 --> Global  1 --> Land  2 --> Sea
+C
+C     Output:
+C     ------
+C                kind   : point index of minimum (integer)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.1       L. Terray      96/09/25  created
+C       2.2       L. Terray      97/02/12  modified: printing bug on 
+C                                          variable kind corrected
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) rminim, pa(kna)
+      INTEGER (kind=ip_intwp_p) kmsk(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Find the maximum 
+C        ----------------
+C
+      itemp = 0
+      ztemp = 0.0
+      IF (kna .LT. 1) GO TO 110
+ 130  itemp = itemp + 1
+      IF (itemp .GT. kna) THEN
+          CALL prtout
+     $        ('WARNING!!! initial search exceeds array size 
+     $        kna  = ', kna, 2)
+          GO TO 140
+      ENDIF 
+      IF (kflag .EQ. 0) THEN
+          ztemp = pa(itemp)
+          GO TO 140
+        ELSE IF (kflag .EQ. 1) THEN
+          IF (kmsk(itemp) .EQ. 1) THEN 
+              ztemp = pa(itemp)
+              GO TO 140
+          ENDIF 
+        ELSE IF (kflag .EQ. 2) THEN
+          IF (kmsk(itemp) .EQ. 0) THEN 
+              ztemp = pa(itemp)
+              GO TO 140
+          ENDIF
+      ENDIF 
+      GO TO 130
+ 140  CONTINUE 
+C* Assign index to initial point
+      kind = itemp
+      IF (kna .LT. 2) GO TO 110
+C* Start looping on all other points
+      IF (kflag .EQ. 1) THEN
+	DO 120 ja = itemp+1, kna 
+            IF (pa(ja) .LT. ztemp .AND. kmsk(ja) .EQ. 1) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF
+ 120    CONTINUE 
+      ELSE IF (kflag .EQ. 2) THEN 
+	DO 125 ja = itemp+1, kna
+            IF (pa(ja) .LT. ztemp .AND. kmsk(ja) .EQ. 0) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF 
+ 125    CONTINUE
+      ELSE IF (kflag .EQ. 0) THEN 
+	DO 127 ja = itemp+1, kna
+            IF (pa(ja) .LT. ztemp) THEN
+                ztemp = pa(ja)
+                kind = ja
+            ENDIF
+ 127    CONTINUE
+      ENDIF 
+ 110  CONTINUE
+      rminim = ztemp
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/skip.f90
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/skip.f90	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/skip.f90	(revision 1677)
@@ -0,0 +1,62 @@
+SUBROUTINE skip (cd_one, id_len)
+!
+!**** SKIP
+!
+!     Purpose:
+!       Skip line if it is a comment
+!
+!     Interface: 
+!       Call skip (cl_one)
+!
+!     Method:
+!       Read the first caracter of the line and skip line if 
+!       it is a comment
+!
+!     External:
+!       none
+!
+!     Files:
+!       none
+!   
+!     References:
+!
+!     History:
+!     --------
+!       Version   Programmer     Date        Description
+!       ------------------------------------------------
+!       2.5       A.Caubel       2002/04/04  created
+!
+!*-----------------------------------------------------------------------
+!
+!** + DECLARATIONS
+!
+!
+!** ++ Include files
+!
+  USE mod_kinds_oasis
+  USE mod_unit
+!
+!** ++ Local declarations
+!
+  INTEGER (kind=ip_intwp_p) :: ib,id_len
+  CHARACTER(len=80) :: cl_line
+  CHARACTER(len=1), DIMENSION(id_len) :: cd_one
+  CHARACTER(len=1) :: cl_two
+!
+!*-----------------------------------------------------------------------
+!
+  cl_two='#'
+100 IF (cd_one(1) .NE. cl_two) GO TO 120
+  READ (UNIT = nulin, FMT = 1001) cl_line
+  DO ib = 1,id_len
+    cd_one(ib) = cl_line(ib:ib)
+  END DO
+  GO TO 100
+120 CONTINUE 
+1001 FORMAT(A80)
+!
+!*-----------------------------------------------------------------------
+!
+END SUBROUTINE skip
+!
+!*========================================================================
Index: CPL/oasis3/trunk/src/mod/oasis3/src/sqdis.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/sqdis.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/sqdis.f	(revision 1677)
@@ -0,0 +1,122 @@
+      FUNCTION sqdis (px1, py1, px2, py2)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *sqdis*  - Arithmetic function
+C
+C     Purpose:
+C     -------
+C     Calculate the distance squared between 2 points on a spheric grid
+C
+C**   Interface:
+C     ---------
+C       *zs =*  *sqdis (px1, py1, px2, py2)*
+C
+C     Input:
+C     -----
+C                px1    : longitude of first point 
+C                py1    : latitude of first point
+C                px2    : longitude of second point
+C                py2    : latitude of second point
+C
+C     NB: the coordinates must be in degrees
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Function declarations -------------------
+C
+      REAL (kind=ip_realwp_p) sqdis, fast
+      fast(x,y,z) = cos(x)*cos(y)*z + sin(x)*sin(y)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Calculate distance
+C        ------------------
+C
+C* Degree to radians --> zcon = 2. pi / 360.
+C 
+      zconv = 1.74532925199432957692e-2 
+      zfi1 = px1 * zconv
+      zth1 = py1 * zconv
+      zfi2 = px2 * zconv
+      zth2 = py2 * zconv
+C
+C* Scalar product
+C
+      ztp1 = fast(zfi1, zfi2, 1.)
+      zsca = fast(zth1, zth2, ztp1)
+C
+C* Angular distance
+C
+      IF (zsca .GT. 1.) THEN
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' Scalar product is greater than 1 '
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' for point 1 -->  longitude = ', px1
+          WRITE(UNIT = nulan,FMT = *) 
+     $        '             -->  latitude  = ', py1
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' and point 2 -->  longitude = ', px2
+          WRITE(UNIT = nulan,FMT = *) 
+     $        '             -->  latitude  = ', py2
+          WRITE(UNIT = nulan,FMT = *)  
+     $        ' Scalar product  zsca = ', zsca
+          zsca =1.
+      ENDIF
+      IF (zsca .LT. -1.) THEN 
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' Scalar product is less than -1 '
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' for point 1 -->  longitude = ', px1
+          WRITE(UNIT = nulan,FMT = *) 
+     $        '             -->  latitude  = ', py1
+          WRITE(UNIT = nulan,FMT = *) 
+     $        ' and point 2 -->  longitude = ', px2
+          WRITE(UNIT = nulan,FMT = *) 
+     $        '             -->  latitude  = ', py2
+          WRITE(UNIT = nulan,FMT = *)  
+     $        ' Scalar product  zsca = ', zsca
+          zsca = -1.
+      ENDIF
+C
+C* Get the distance
+C              
+      zalp = acos(zsca)
+      sqdis = zalp * zalp
+C
+C* End of function
+C
+      RETURN 
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/ssumr.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/ssumr.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/ssumr.f	(revision 1677)
@@ -0,0 +1,73 @@
+      FUNCTION ssumr (pa, kna)
+C****
+C               ******************************
+C               * OASIS FUNCTION  -  LEVEL T *
+C               * --------------     ------- *
+C               ******************************
+C
+C**** *ssumr*  - Arithmetic function
+C
+C     Purpose:
+C     -------
+C     Sum of the elements of a real array
+C
+C**   Interface:
+C     ---------
+C       *zs =*  *ssumr (pa, kna)*
+C
+C     Input:
+C     -----
+C                pa     : array to be summed (real 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) ssumr, pa(kna)
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Perform the sum
+C        ---------------
+C
+      ztemp = 0.
+      DO 110 ji = 1, kna
+        ztemp = ztemp + pa(ji)
+ 110  CONTINUE
+      ssumr = ztemp
+C
+C* End of function
+C
+      RETURN 
+      END
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/subgrid.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/subgrid.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/subgrid.f	(revision 1677)
@@ -0,0 +1,224 @@
+      SUBROUTINE subgrid (pfldn, pfldo, ksizn, ksizo,
+     $                    pcoar, pfine, pdqdt,
+     $                    cdfic, kunit, knumb, cdname,
+     $                    pwork, kwork, knbor, ldread, cdtype)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 3 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *subgrid* - submesh variabiity
+C
+C     Purpose:
+C     -------
+C     Interpolate with subgrid linear technique. This is  rigorously
+C     conservative if the models exchange fields at every timestep
+C     and if sea-land mismatch is accounted for.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *subgrid (pfild, ksize, pcoar, pfine, pdqdt)*
+C
+C     Input:
+C     -----
+C                pfldo  : initial field on source grid (real 1D)
+C                ksizn  : size of final field array (integer)
+C                ksizo  : size of initial field array (integer)
+C                pcoar  : coarse grid additional field (real 1D)
+C                pfine  : fine grid additional field (real 1D)
+C                pdqdt  : coarse grid coupling ratio (real 1D)
+C                kunit  : logical unit numbers for subgrid file (integer)
+C                cdfic  : filename for subgrid data (character)
+C                knumb  : subgrid dataset identity number (integer)
+C                cdname : name of final field on target grid (character)
+C                pwork  : temporary array to read subgrid weights (real 1D)
+C                kwork  : temporary array to read subgrid array (integer 1D)
+C                knbor  : maximum number of source grid neighbors with non zero
+C                         intersection with a target grid-square (integer)
+C                         The source grid is here the coarse grid while the
+C                         target grid is the fine one.
+C                ldread : logical flag to read subgrid data (logical)
+C                cdtype : type of subgrid interpolation (character)
+C
+C     Output:
+C     ------
+C                pfldn  : final field on target grid (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      96/02/01  created
+C       2.1       L. Terray      96/08/05  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+      USE mod_printing
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p) pfldn(ksizn), pfldo(ksizo)
+      REAL (kind=ip_realwp_p) pcoar(ksizo), pfine(ksizn), pdqdt(ksizo)
+      REAL (kind=ip_realwp_p) pwork(knbor,ksizn)
+      INTEGER (kind=ip_intwp_p) kwork(knbor,ksizn)
+      CHARACTER*8 cdfic, cdname, cdtype
+      LOGICAL ldread
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clweight, cladress
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE subgrid  -  Level 3'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ***************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Linear subgrid interpolation'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C* initialize error flag for I/O routine
+C
+      iflag = 0
+C
+C
+C*    2. Read subgrid data the first time
+C        --------------------------------
+C
+      IF (ldread) THEN 
+C
+C* Initialize locators and array sizes
+C
+          WRITE(clweight,'(''WEIGHTS'',I1)') knumb
+          WRITE(cladress,'(''ADRESSE'',I1)') knumb
+          isize = ksizn * knbor
+C
+C* Adress of overlapped points on source grid
+C
+          CALL locrint (cladress, kwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading 
+     $            subgrid data for field',
+     $            cdname, 1)
+              CALL prcout
+     $            ('Could not get adress array', cladress, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in subgrid') 
+          ENDIF
+C
+C* Weights of overlapped points on source grid
+C
+          CALL locread (clweight, pwork, isize, kunit, iflag)
+C
+C* Checking
+C
+          IF (iflag .NE. 0) THEN 
+              CALL prcout
+     $            ('WARNING: problem in reading 
+     $            subgrid data for field',
+     $            cdname, 1)
+              CALL prcout
+     $            ('Could not get weight array', clweight, 1)
+              CALL prtout
+     $            ('Error reading logical unit', kunit, 1)
+              CALL prcout
+     $            ('It is connected to file', cdfic, 1)
+              CALL HALTE ('STOP in subgrid') 
+          ENDIF
+          ldread = .FALSE. 
+      ENDIF
+C
+C
+C*    3. Modify main field according to type of subgrid interpolation
+C        ------------------------------------------------------------
+C* Case of non solar flux
+C
+      IF (cdtype .EQ. 'NONSOLAR') THEN
+C
+C* Loop on all target points
+C
+          DO 310 ji = 1, ksizn
+            zsum = 0.0
+C
+C* Loop on active neighbors
+C
+            DO 320 jk = 1, knbor
+              IF (kwork(jk,ji) .gt. 0) then
+              zsum = zsum + pwork(jk,ji) *
+     $            ( pfldo(kwork(jk,ji)) + pdqdt(kwork(jk,ji)) 
+     $            * ( pfine(ji) - pcoar(kwork(jk,ji)) ) )
+              ENDIF
+ 320        CONTINUE 
+            pfldn(ji) = zsum
+ 310      CONTINUE
+C
+C* Case of solar flux
+C
+        ELSE IF (cdtype .EQ. 'SOLAR') THEN
+          DO 330 ji = 1, ksizn
+            zsum = 0.0
+C
+C* Loop on active neighbors
+C
+            DO 340 jk = 1, knbor
+              IF (kwork(jk,ji) .gt. 0) then
+              zsum = zsum + pwork(jk,ji) * pfldo(kwork(jk,ji)) *
+     $            ( 1. - pfine(ji)) / ( 1. - pcoar(kwork(jk,ji)))
+              ENDIF
+ 340        CONTINUE
+            pfldn(ji) = zsum
+ 330      CONTINUE
+      ENDIF 
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine subgrid ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/szero.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/szero.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/szero.f	(revision 1677)
@@ -0,0 +1,77 @@
+      SUBROUTINE szero (pa, kna)
+C****
+C               ********************************
+C               * OASIS SUBROUTINE  -  LEVEL T *
+C               * ----------------     ------- *
+C               ********************************
+C
+C**** *szero*  - Utility routine
+C
+C     Purpose:
+C     -------
+C     Zero real array from element 1 to element kna
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *szero (ka, kna)*
+C
+C     Input:
+C     -----
+C                pa     : array to be zeroed (real 1D)
+C                kna    : array dimension (integer)
+C
+C     Output:
+C     ------
+C                pa     : array filled up with zeros (real 1D)
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_unit
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL (kind=ip_realwp_p)  pa(kna)
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      REAL (kind=ip_realwp_p) zero
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Zero the array 
+C        ---------------
+C
+      zero = 0.000000000000000E0
+      DO 110 ja = 1, kna
+        pa(ja) = zero
+  110 CONTINUE
+C
+C
+C*    2. End of routine
+C        --------------
+C
+      RETURN
+      END
Index: CPL/oasis3/trunk/src/mod/oasis3/src/updtim.f
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/updtim.f	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/updtim.f	(revision 1677)
@@ -0,0 +1,175 @@
+      SUBROUTINE updtim (kiter)
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 1 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *updtim*  - Update time
+C
+C     Purpose:
+C     -------
+C     Increment date since run start
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *updtim (kiter)*
+C
+C     Input:
+C     -----
+C                kiter : iteration number
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C                ilmoi  : work array for calendar months length (integer 1D)
+C
+C     Externals:
+C     ---------
+C     calend
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/09/01  modified: new structure
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and use of modules---------------------------
+C
+      USE mod_kinds_oasis
+      USE mod_parameter
+      USE mod_timestep
+      USE mod_unit
+      USE mod_calendar
+      USE mod_printing
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) ilmoi(12)
+C
+C* ---------------------------- Local functions -------------------------
+C
+C* - Time functions
+C            ncth  --->>> turn seconds into hours
+C
+      ncth(ksec) = ksec / 3600
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initializations
+C        ---------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE updtim  -  Level 1'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    ' Increment model date since run start '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+      ilmoi(:)=0
+      IF (lg_oasis_field) THEN
+C
+C* Check if we go to next day
+C
+C* Simulated time in seconds
+C
+      isecond = kiter * nstep
+      zsecond = float (isecond)
+C
+C* Get number of days completed so far
+C
+      iday = int ((zsecond+0.5) / 86400.)
+C
+C* Get seconds gone for current day
+C
+      idaysec = iday * 86400
+      ihour = ncth (isecond - idaysec)
+C
+C
+C*    2. Get time data
+C        -------------
+C
+      CALL calend (njini, nmini, naini, iday, ncaltype, 
+     $             njnow, nmnow, nanow, ilmoi)
+C
+C
+C*    3. Print current date and time
+C        ---------------------------
+C
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '               ****************** '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '               * Model run date * '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '               * -------------- * '
+      WRITE (UNIT = nulou,FMT = *) 
+     $    '               ****************** '
+      WRITE (UNIT = nulou,FMT = *) ' '
+      WRITE (UNIT = nulou,FMT = *) '            Year  --->>> ',nanow
+      WRITE (UNIT = nulou,FMT = *) '           Month  --->>> ',nmnow
+      WRITE (UNIT = nulou,FMT = *) '             Day  --->>> ',njnow
+      WRITE (UNIT = nulou,FMT = *) '            Hour  --->>> ',ihour
+      WRITE (UNIT = nulou,FMT = *) ' '
+      IF (njnow .GT. 15) THEN
+          nmone = nmnow
+          nmtwo = 1 + MOD(nmnow,12)
+          njone = 15
+          njtwo = 15 + ilmoi(nmone)
+          ndone = 15
+          ndtwo = ilmoi(nmone)
+          nsrec = nmnow
+          IF (njdeb .LT. 15) THEN
+              nmrec = nmnow + 12 * (nanow - nadeb) - nmdeb + 1
+            ELSE 
+              nmrec = nmnow + 12 * (nanow - nadeb) - nmdeb
+          ENDIF 
+        ELSE
+          nmone = 1 + MOD(nmnow + 10,12)
+          nmtwo = nmnow
+          njone = 15 - ilmoi(nmone)
+          njtwo = 15
+          ndone = 0
+          ndtwo = 15
+          nsrec = nmnow - 1
+          IF (njdeb .LT. 15) THEN 
+              nmrec = nmnow + 12 * (nanow - nadeb) - nmdeb
+            ELSE 
+              nmrec = nmnow - 1 + 12 * (nanow - nadeb) - nmdeb
+          ENDIF
+      ENDIF
+      ENDIF
+C
+C
+C*    4. End of routine
+C        --------------
+C
+      IF (nlogprt .GE. 1) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine updtim ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
+
Index: CPL/oasis3/trunk/src/mod/oasis3/src/waitpc.F
===================================================================
--- CPL/oasis3/trunk/src/mod/oasis3/src/waitpc.F	(revision 1677)
+++ CPL/oasis3/trunk/src/mod/oasis3/src/waitpc.F	(revision 1677)
@@ -0,0 +1,181 @@
+      SUBROUTINE waitpc
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL C *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *waitpc*  - Insure proper termination of simulation
+C
+C     Purpose:
+C     -------
+C     Wait for gcm's termination so that child processes end up
+C     before their parent.
+C     Use system call wait to pause calling process until
+C     completion of child processes.
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *waitpc*
+C
+C     Input:
+C     -----
+C     None
+C
+C     Output:
+C     ------
+C     None
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     wait, waitcld, SIPC_End, CLIM_Quit
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1997)
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       1.0       L. Terray      94/01/01  created
+C       2.0       L. Terray      95/09/01  modified: new structure
+C       2.2       S. Valcke      97/09/03  added: introduction of SVIPC
+C       2.2       L. Terray      97/12/24  added: change waitsipc routine
+C       2.3       S. Valcke      99/04/30  added: printing levels
+C       2.3       L. Terray      99/09/15  added: GMEM branch. replace
+C                                                 SIPC_Destroy by SIPC_End
+C       2.5       S. Valcke      2K/09/04  Remove cmach
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------- Include files and USE of modules---------------------------
+C
+      USE mod_kinds_oasis
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+      USE mod_clim
+#endif
+      USE mod_parameter
+      USE mod_sipc
+      USE mod_experiment
+      USE mod_pipe
+      USE mod_nproc
+      USE mod_unit
+      USE mod_hardware
+      USE mod_printing
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      INTEGER (kind=ip_intwp_p) wait
+      INTEGER (kind=ip_intwp_p) iwone
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           ROUTINE waitpc  -  Level C'
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '           **************     *******'
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) ' Wait until gcm completion '
+          WRITE (UNIT = nulou,FMT = *) ' Exit if interpolator only '
+          WRITE (UNIT = nulou,FMT = *) ' '
+      ENDIF
+C
+C
+C*    2. Wait until gcm's completion  
+C        ---------------------------
+C
+      iwone = 0
+      IF (cchan .EQ. 'PIPE' .OR. cchan .EQ. 'SIPC'
+     $    .OR. cchan .EQ. 'GMEM') THEN 
+          DO 210 jm = 1, ig_nmodel
+#ifdef use_comm_PIPE            
+            iwone = wait(isone)
+#elif defined use_comm_SIPC || defined use_comm_GMEM   
+            CALL waitcld(isone,iwone)
+#endif
+            IF (iwone .eq. -1) THEN
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>> Model numbered = ', jm
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ======         ====        ====     '
+                WRITE (UNIT = nulou,FMT = *) 
+     $          ' was not an running child when waitpc was called '
+                CALL FLUSH(nulou)
+            ELSE
+                DO 220 jk = 1, ig_nmodel
+                  IF (iwone .EQ. nproc(jk)) THEN
+                      IF (nlogprt .GE. 1) THEN 
+                          CALL prcout
+     $                    ('End of simulation for model named', 
+     $                     cmodnam(jk), 1)
+                          CALL prtout
+     $                    ('Exit of process nproc =', nproc(jk), 1)
+                          WRITE (UNIT = nulou,FMT = *) 
+     $                    ' coupler waits until end of other gcms '
+                      ENDIF
+                      GO TO 210
+                  ENDIF 
+ 220            CONTINUE 
+                WRITE (UNIT = nulou,FMT = *) '        ***WARNING***'
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ===>>> : first wait return code is = '
+     $              ,iwone
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' ======         ====        ====      '
+                WRITE (UNIT = nulou,FMT = *) ' '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' Either gcm is probably multitasked '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' The leaving process with pid = ', iwone
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' is different from the initial process values  '
+                WRITE (UNIT = nulou,FMT = *) 
+     $              ' We go on til normal termination !!!'
+             ENDIF
+ 210      CONTINUE
+C
+C* Destroy shared-memory pools used for exchanging fields and
+C  pool for reading/writing initial infos from/to models
+C
+#if defined use_comm_SIPC || use_comm_GMEM
+          CALL SIPC_End(ig_nmodel)
+#endif
+C
+       ENDIF
+#if defined use_comm_MPI1 || defined use_comm_MPI2 || !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
+       CALL CLIM_Quit( infos)
+       IF (infos .NE. CLIM_Ok) THEN
+          CALL prtout
+     $         ('An error occured while leaving CLIM. Error =',
+     $         infos, 2)
+       ENDIF
+#endif
+C
+C
+C
+C*    3. End of program
+C        --------------
+C
+      IF (nlogprt .GE. 2) THEN
+          WRITE (UNIT = nulou,FMT = *) ' '
+          WRITE (UNIT = nulou,FMT = *) 
+     $    '          --------- End of routine waitpc ---------'
+          CALL FLUSH (nulou)
+      ENDIF
+      RETURN
+      END
+
Index: CPL/oasis3/trunk/util/compile/Append_dependencies
===================================================================
--- CPL/oasis3/trunk/util/compile/Append_dependencies	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/Append_dependencies	(revision 1677)
@@ -0,0 +1,895 @@
+#! /bin/ksh
+#
+#  Usage : Create_dependencies.pl 'modelname' 'source code directory'
+#
+#  Limits: the name of the file which contains a module 
+#          and the module name must be the same.
+#
+#  Functionality: 
+#
+#  The script..
+#
+#   1.) checks all files in 'source code directory' ('scd') for
+#       inclusion of header files (#include or INCLUDE) 
+#       or usage of Fortran modules.
+#   2.) It outputs for each file in 'scd' a dependency record with prerequisites
+#       ('header file name' or 'module name'.o) for use in the Makefile of 'scd' 
+#       if any dependency was found.
+#   3.) It checks for all prerequisites whether the file (for header files) or 
+#       a 'module name'.[f,F][90] resides in 'scd'
+#   4.) Those which do not reside in 'scd' are searched in all other
+#       source code directories at the same directory tree level.
+#       If directories with platform dependent code exist, only the relevant
+#       directories are checked.
+#   5.) If not found in any of the other source code directories, 
+#       the file is listed (e.g. psmile routines, platform dependent
+#       include (header) files
+#   6.) If found, a 2nd level dependency check is done:
+#       7.) The 2nd level dependency check includes steps 
+#           2.) for the prerequisites already found
+#           3.) checks for all prerequisites whether there reside in the same dir
+#           4.) Those which do not reside in 'scd' are searched in all other
+#               source code directories at the same directory tree level.
+#           5.) If not found in any of the other source code directories, 
+#               the file is listed
+#           6.) If found new prerequisites are added
+#   8.) For some model another iteration is added
+#   9.) Finally, 
+#       - directories other than 'scd' are listed for inclusion in the VPATH 
+#         parameter of Makefile_1 if needed
+#       - a list with unresolved dependencies is given.
+#
+#   Unresolved dependencies may be resolved manually
+#   (e.g. prism_kind_proto in the component models) and
+#   listed in Makefile_1. They will not be lost with the new 
+#   creation of 'Makefile' since the dependency  are appended.
+#
+
+#
+# Two command line parameters are mandatory
+#
+
+if [ "$2" = "" ] ; then
+  echo '***************************************************************'
+  echo '* '
+  echo '* This script must be called with 2  parameters:'
+  echo '*   1. model name (directory name of the model source code)'
+  echo '*   2. source code subdirectory for which to create the Makefile '
+  echo '* One or both of the parameters is empty!'
+  echo '* The script is stopped!'
+  echo '* '
+  echo '* A 3rd parameter (nodename for a valid PRISM site) is optional.'
+  echo '* '
+  echo '***************************************************************'
+  exit 1
+fi
+
+#
+# Set 3rd parameter (processor type) for MOZART
+#
+if [ "$1" = "mozart" ]; then
+  node=`uname -n`
+  if [ ! "$3" = ""  ]; then
+    node=$3
+  fi
+  node12=`echo $node | cut -c1-2`
+  node13=`echo $node | cut -c1-3`
+  node14=`echo $node | cut -c1-4`
+  if [ "$node12" = "ds" ]; then
+    proctype=vector
+  elif [ "$node" = "dcm13" ]; then
+    proctype=cache
+  elif [ "$node" = "dcm23" ]; then
+    proctype=cache
+  elif [ "$node" = "elnino" ]; then
+    proctype=cache
+  elif [ "$node14" = "hpca" ]; then
+    proctype=cache
+  elif [ "$node12" = "p1" ]; then
+    proctype=cache
+  elif [ "$node14" = "xbar" ]; then
+    proctype=vector
+  elif [ "$node" = "SFV800" ]; then
+    proctype=vector
+  else
+    echo Unknown site! 
+    echo The script is stopped!
+  fi
+fi
+
+scriptname=`basename $0`
+scriptdirec=`dirname $0`
+perlname=`which perl | grep /perl`
+export perlname
+
+cat > ${scriptname}.pl << EOF
+#!$perlname
+EOF
+cat >> ${scriptname}.pl << \EOF
+#
+# Based on createMakefiles.pl by
+#            Uwe Schulzweida <schulzweida@dkrz.de> June, 1999
+# Stephanie Legutke, MPI M&D Oct 2003
+#   - loop on all source code directories for prerequisites 
+#     at the 2nd level
+# Stephanie Legutke, MPI M&D June 2004
+#   - '# include' (with blanks allowed)
+#   - 3rd level check added June 2004
+#
+####################################################################
+
+$PROG=`basename $0`;
+
+$scriptdir=@ARGV[0];
+$modname=@ARGV[1];
+$dir=@ARGV[2];
+$proctype=@ARGV[3];
+
+#
+# Print directories
+#
+
+$presdir=`pwd`;
+chdir $presdir;
+chdir $scriptdir;
+$scriptdir=`pwd`;
+chdir "../../src/mod/";
+$srcdir=`pwd`;
+
+#
+# Check whether valid model
+#
+if ( ! -d $modname ) {
+  print "******************************************************** \n";
+  print "*\n";
+  print "* This script must be called with 2 parameters:\n";
+  print "* 1. model name (directory name of the model source code \n";
+  print "*                                       (all lower case))\n";
+  print "* 2. source code subdirectory (for which to create make  \n";
+  print "*                                          dependencies) \n";
+  print "* The first parameter is not a valid model name:\n";
+  print "*    model name = $modname\n";
+
+# Create list of models.
+
+  opendir (MODDIR, ".");
+  foreach $file (readdir(MODDIR)) {
+     if ( -d $file ) {
+        ($nfile = $file) =~ (s/^\.//) ;    
+        if ( ("$file" eq "$nfile") ) {
+          push (@modlist, $file);
+        }
+     }
+  }
+  close (MODDIR);
+  print "*    Valid models are : @{modlist}\n";
+  print "*\n";
+  print "******************************************************** \n";
+  exit;
+}
+
+chop(${srcdir});
+$moddir="${srcdir}/".${modname};
+print "********************************************************\n";
+print "* Source root directory : $srcdir\n";
+print "* Model name            : $modname\n";
+
+chdir $modname;
+
+#
+# Processor type dependent strings for selection of directories
+#
+$string1=" ";
+$string2=" ";
+if ( "$modname" eq "mozart" ) {
+  if  ( "$proctype" eq "vector" )  {
+    $string1="cache";
+    $string2="scalar";
+    print "* Makefile dependencies will be created for a vector processor \n";
+    print "*                         maschine from the vector-directories.\n";
+
+  }
+  if  ( "$proctype" eq "cache" )  {
+    $string1="vector";
+    $string2="scalar";
+    print "* Makefile dependencies will be created for a cache processor \n";
+    print "*                         maschine from the cache-directories.\n";
+  }
+  if  ( "$proctype" eq "scalar" )  {
+    $string1="cache";
+    $string2="scalar";
+    print "* Makefile dependencies will be created for a scalar processor \n";
+    print "*                         maschine from the scalar-directories.\n"
+  }
+}
+#
+# List of source code directories
+#   (For compilation of mozart  exclude
+#    the $string1 and $string2 directories.)
+#
+undef @dirlist;
+opendir (MODDIR, ".");
+foreach $file (readdir(MODDIR)) {
+   if ( -d $file ) {
+      ($nfile = $file) =~ (s/^\.//) ;
+      ($n1file = $nfile ) =~ (s/$string1//) ;
+      ($n2file = $n1file ) =~ (s/$string2//) ;
+      if ( ( "$file" ne "doc" ) && ("$file" eq "$n2file") ) {
+         push (@dirlist, $file);
+      }
+   }
+}
+
+close (MODDIR);
+
+# if ( "$modname" eq "mozart" )  {
+   if ( ( $dir eq "" ) || ( ! -d $dir )) {
+        print "******************************************************** \n";
+        print "*\n";
+        print "* This script must be called with 2 parameters:\n";
+        print "* 2. source code subdirectory   \n";
+        print "*          (for which to create Makefile dependencies) \n";
+        print "*    The specified vakue is not a valid directory name.\n";
+        print "*    Valid directories are : @{dirlist}\n";
+        print "*\n";
+        print "******************************************************** \n";
+        exit;
+   }
+#}
+
+print "* Create dependencies for Makefile in  source code directory : $dir\n";
+
+#
+# Work on directory @ARGV[1]; can be changed in a loop on @dirlist later
+#
+
+chdir $dir;
+
+#
+# Check for Makefile_1
+#
+
+$file="Makefile_1";
+if ( ! (-f $file) ) {
+   print "* No Makefile_1 in directory $dir !!\n";
+   exit;
+}
+
+#
+# Remove old Makefile
+#
+
+$file="Makefile";
+if ( -f $file ) {
+   unlink ($file);
+}
+
+#
+# Open new Makefile
+#
+
+open(DEPENDS, ">> Makefile");
+print DEPENDS "\n";
+print DEPENDS "# This file is generated automatically\n";
+
+#
+# Copy body of Makefile
+#
+
+open(MAKEBODY, "Makefile_1");
+while ( ( $line = <MAKEBODY>) && ( "$line" ne "# Dont add anything behind this line\n" ) ) {
+  print DEPENDS "$line"; 
+}
+print DEPENDS "\n";
+close(MAKEBODY);
+
+
+#
+# Create dependency listings (dirlist=all directories)
+#
+
+&MakeDepends(@{dirlist});
+chdir "..";
+chdir @ARGV[2];
+
+#
+# Add more iteration
+#
+
+$times=0;
+
+if ( @ARGV[1] eq "mozart" && @ARGV[2] eq "base"       ) { $times=2; }
+if ( @ARGV[1] eq "mozart" && @ARGV[2] eq "base_vector") { $times=2; }
+if ( @ARGV[1] eq "mozart" && @ARGV[2] eq "chem"       ) { $times=1; }
+if ( @ARGV[1] eq "mozart" && @ARGV[2] eq "chem_vector") { $times=1; }
+ 
+foreach $time ( 1 .. $times ) { 
+  print "* Add Second Iteration\n";
+  &AddDepends(@{Dirlist}); 
+  chdir "..";
+  chdir @ARGV[2];
+  rename(Makefile_new,Makefile);
+}
+
+exit;
+
+############################################################################
+#
+# Usage &MakeDepends(@dirlist);
+# @_ = @dirlist = $directories
+# @directories: list of all model directories (excl. 'doc')
+# $presdir:     present directory
+# @dirs:        list of all model directories (excl. 'doc' and present)
+# %Filename:    key=module name of Fortran files in present directory
+#               value= file name (no .h file)
+# %dotOname:    key=module name of Fortran files in present directory
+#               value= $Filename.o (no .h file)
+# for each $file in present directory:  @modules list of modules used
+#                                       @incs    list of files included
+# for each $file in present directory: $objfile=$Filename.o (.h unchanged)
+#
+#
+sub MakeDepends {
+   local(@dependencies);
+   local(%dotOname);
+   local(%Filename);
+   local(@incs);
+   local(@modules);
+   local(@directories);
+   local($objfile);
+
+   @directories = @_ ;
+#
+# Eliminate present directory $presdir from directory list
+#
+   $presdir=`pwd`;
+   $presdir=`basename $presdir`;
+   chop($presdir);
+   foreach $dir (@directories) {
+      if ( $dir ne $presdir ) {
+         push(@dirs, $dir);
+      }
+   }
+
+#
+# Associate each module with the name of the file (%Filename) it is contained in.
+#
+   foreach $file (<*.F90 *.f90 *.F *.f>) {
+      open(FILE, $file) || warn "Cannot open $file: $!\n";
+      while (<FILE>) {
+         /^\s*module\s+([^\s!]+)/i &&
+            ($Filename{&toLower($1)} = $file) ;
+      }
+      close (FILE);
+   }
+
+#
+# Replace Fortran suffixes with '.o' in (%dotOname)
+#
+   while (($key,$vari) = each(%Filename)) {
+     ($dotOname{$key}=$Filename{$key}) =~ s/\.[f,F].*$/.o/i;
+   }
+
+#
+# Note: according to PRISM coding rules filename must be module name
+#  
+   while (($key,$vari) = each(%Filename)) {
+      ($testname=$Filename{$key}) =~ s/\.[f,F].*$//i;
+      if (&toLower($testname) ne $key && $key ne "procedure") {
+         print " File/Module name:   ${Filename{$key}} , $key\n";
+         print " This is not allowed! \n";
+      }
+   }
+
+#
+# Loop on files in present directory for dependency search
+#
+   foreach $file (<*.F90 *.f90 *.F *.f *.c *.h>) {
+
+#
+# Get object file name (Fortran and c, .h file names remain unchanged)
+# references one or more modules
+#
+      ($objfile = $file)    =~ s/\.[f,F].*$/.o/i;
+      ($objfile = $objfile) =~ s/\.c$/.o/;
+      open(FILE, $file);
+      while (<FILE>) {
+          /^\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+          /^\s*#\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+          /^\s*use\s+([^\s,!]+)/i && push(@modules, &toLower($1));
+      }
+
+      if (defined @incs && $#incs < 0) {undef @incs;}
+
+      undef @redmodules;
+      if (defined @modules) {
+         foreach $mod (@modules) {
+            if ("&toLower($objfile)" ne "&toLower($dotOname{$mod})") {
+               push(@redmodules,$mod);
+            } else {
+               print "*     => reflective use: $objfile: $mod\n";
+            }
+         }
+      }
+      @modules=@redmodules;
+#
+# Add .o- name for modules not in present directories (needs refinement)
+#
+
+      foreach $mod (@modules) {
+         if ( ${dotOname{$mod}} eq "" ) {
+                ${dotOname{$mod}}=$mod."\.o";
+         }
+      }
+
+      if (defined @modules && $#modules < 0) {undef @modules;}
+#
+# If dependecies or includes are present ...
+#
+      if (defined @incs || defined @modules) {
+#
+#  ...but not in present directory: list file name @otherincs/@othermods
+#
+        foreach $inc (@incs) {
+           open(INC, $inc) || push(@otherincs, $inc);
+        }
+        foreach $mod (@modules) {
+           open(MOD, $Filename{$mod}) || push(@othermods, $mod);
+        }
+#
+#  ... add line do Makefile (present dir only)
+#
+#
+#  Define dotOname (@modules)???
+#
+        print DEPENDS "$objfile: ";
+        undef @dependencies;
+        foreach $module (@modules) {
+           push(@dependencies, $dotOname{$module});
+        }
+        @dependencies = &uniq(sort(@dependencies));
+        &PrintWords(length($objfile) + 2, 0,
+                   @dependencies, &uniq(sort(@incs)));
+        print DEPENDS "\n";
+        undef @incs;
+        undef @modules;
+      }
+   }
+   #
+   # End of loop on files in present directory for dependency search
+   #
+      
+   @remainincs = &uniq(sort(@otherincs));
+   @remainmods = &uniq(sort(@othermods));
+   if ( defined @otherincs ) {
+     print "* \n";
+     $no_remincs=@remainincs;
+     $ele_1=0;
+     $ele_2=0;
+     print "* Included files not in present directory:\n";
+     until ( $ele_2 > $no_remincs ) {
+       $ele_2=$ele_1 + 3;
+       print "           @remainincs[$ele_1 .. $ele_2]\n";
+       $ele_1=$ele_2 + 1;
+     }
+   }
+   if ( defined @othermods ) {
+     print "* \n";
+     $no_remmods=@remainmods;
+     $ele_1=0;
+     $ele_2=0;
+     print "* Used modules not in present directory: \n";
+     until ( $ele_2 > $no_remmods ) {
+       $ele_2=$ele_1 + 3;
+       print "           @remainmods[$ele_1 .. $ele_2]\n";
+       $ele_1=$ele_2 + 1;
+     }
+   }
+   if ( defined @othermods || defined @otherincs ) {
+     print "* \n";
+     print "* They are searched in the other directories,\n";
+     print "*   i.e. in \"@dirs\"\n";
+     print "* \n";
+     print "* Warning: In this 2nd iteration it will not be checked whether  \n";
+     print "*          the files included or the modules used in these files \n";
+     print "*          exist in the present or in any of the model directories.\n";
+     print "*          To do this another iteration (not a rerun) would be needed!\n";
+   }
+   #
+   # Loop on other directories for file search
+   #
+
+   #
+   # Do the included files first... 
+   #
+   foreach $dir (@dirs) {
+      chdir ".." ;
+      chdir $dir;
+      undef @restincs;
+      foreach $file (@remainincs) {
+         open(FILE, $file) || push(@restincs, $file);
+         undef @incs;
+         undef @modules;
+         while (<FILE>) {
+          /^\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+            /^\s*#\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+            /^\s*use\s+([^\s,!]+)/i && push(@modules, &toLower($1));
+            push(@vpathdirs,$dir);
+         }
+         $objfile = $file;
+         if (defined @incs && $#incs < 0) {undef @incs;}
+         if (defined @modules && $#modules < 0) {undef @modules;}
+         foreach $mod (@modules) {
+            if ( ${Filename{$mod}} eq "" ) {
+                 ${dotOname{$mod}}=$mod."\.o";
+            }
+         }
+         if (defined @incs || defined @modules) {
+            print DEPENDS "$objfile: ";
+            undef @dependencies;
+            foreach $mod (@modules) {
+               push(@dependencies, $dotOname{$mod});
+            }
+            @dependencies = &uniq(sort(@dependencies));
+            &PrintWords(length($objfile) + 2, 0,
+                        @dependencies, &uniq(sort(@incs)));
+            print DEPENDS "\n";
+            undef @incs;
+            undef @modules;
+         }
+       }     
+       @remainincs = &uniq(sort(@restincs));
+   }
+
+   @vpathdirs = &uniq(sort(@vpathdirs));
+   if ( $#vpathdirs >= 0) {
+      print "* Header file directories to be included in VPATH: \"@vpathdirs\"\n";
+   }
+   #
+   # Do the uses then ... 
+   #
+   undef @vpathdirs;
+   foreach $dir (@dirs) {
+      undef @restmods;
+      chdir ".." ;
+      chdir $dir;
+      $vpath="no";
+      foreach $Mod (@remainmods) {
+         ${Filename{$Mod}}="";
+         foreach $file (<*.F90 *.f90 *.F *.f>) {
+            ($File = $file)    =~ s/\.[f,F].*$// ;
+            if (&toLower($File) eq $Mod) {
+               ${Filename{$Mod}}=$file;
+            }
+         }
+         if (${Filename{$Mod}} eq "") {
+            push(@restmods, $Mod);
+         }
+         else {
+            $vpath="yes";
+            open(FILE, ${Filename{$Mod}});
+            undef @incs;
+            undef @modules;
+            while (<FILE>) {
+               /^\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+               /^\s*#\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+               /^\s*use\s+([^\s,!]+)/i && push(@modules, &toLower($1));
+            }
+            $objfile = $Mod."\.o";
+            if (defined @incs    && $#incs < 0)    {undef @incs;}
+            if (defined @modules && $#modules < 0) {undef @modules;}
+            if (defined @incs || defined @modules) {
+               print DEPENDS "$objfile: ";
+               undef @dependencies;
+               foreach $mod (@modules) {
+                   push(@dependencies, $mod."\.o");
+               }
+
+               @dependencies = &uniq(sort(@dependencies));
+               &PrintWords(length($objfile) + 2, 0,
+                          @dependencies, &uniq(sort(@incs)));
+               print DEPENDS "\n";
+               undef @incs;
+               undef @modules;
+            }
+         }
+      }
+      @remainmods = &uniq(sort(@restmods));
+      if ( $vpath eq "yes"  ) {
+        push(@vpathdirs,$dir);
+      }
+   }
+   if ( $#vpathdirs >= 0) {
+     print "*\n";
+     print "* Directories to be included in VPATH: \"@vpathdirs\"\n";
+   }
+   if ( $#remainincs >= 0) {
+     print "*\n";
+     print "* Included files not found at all: \"@remainincs\"\n";
+   }
+   if ( $#remainmods >= 0) {
+     print "*\n";
+     print "* Used modules not found at all: \"@remainmods\"\n";
+   }
+   print "*\n";
+   print "* Note: The *prism*/*clim* modules reside in the libraries \n";
+   print "*       \"psmile\"/\"clim\". They are always compiled before \n";
+   print "*       the model and therefore must be included in the INCL\n";
+   print "*       variable only.\n";
+   print "*************************************************************\n";
+}
+
+############################################################################
+#
+# Usage &AddDepends(@dirlist);
+# @_ = @dirlist = $directories
+# @directories: list of all model directories (excl. 'doc')
+# $presdir:     present directory
+# @dirs:        list of all model directories (excl. 'doc' and present)
+# @modules:     list of modules used
+# @incs:        list of files included
+#
+# Scan the already existing dependency-lines of Makefile and check
+#      each .o prerequisite whether it implies 
+#      - new prerequisites and/or 
+#      - new dependency lines
+#
+# 
+#
+#
+sub AddDepends {
+   local(@dependencies);
+   local(%dotOname);
+   local(%Filename);
+   local(@incs);
+   local(@modules);
+   local(@directories);
+   local($objfile);
+
+   @directories = @_ ;
+
+#
+# Scan the existing dependencies (line by line) and add prerequisites
+#
+close (DEPENDS);
+open(DEPENDS, "> Makefile_new");
+
+#
+# Copy body of Makefile
+#
+$line="";
+open(MAKEBODY, "Makefile");
+while ( ( $line = <MAKEBODY>) && ( "$line" ne "# Dont add anything behind this line\n" ) ) {
+  print DEPENDS "$line"; 
+}
+print DEPENDS "\n";
+
+#
+# Loop over all dependency lines ...
+#
+undef $fullline;
+undef @alltargets;
+undef $allprereqs;
+while ( $line = <MAKEBODY> ) {
+#
+# Read full continued line ...
+#
+  ( $nline = $line ) =~ ( s/\\// ) ;    
+  if ( ! ($nline eq $line) ) {
+    chop ($nline);
+    $fullline="$fullline".$nline;
+  }
+  if ( $nline eq $line ) {
+    chop ($nline);
+    $fullline="$fullline".$nline;
+#
+# Work on full line ...
+
+    ( $target  = $fullline ) =~ ( s/:.*$// );
+    push (@alltargets,$target);
+
+    ( $reqline = $fullline ) =~ ( s/.*://   );  
+    ( $reqs = $reqline ) =~ (s/\.h//g);
+    ( $reqs = $reqline ) =~ (s/\.o//g);
+    @prereqs = split(' ',$reqs);
+
+    undef $fullline;
+
+#
+# Loop over prerequisites and extend with new prerequisites
+
+    undef @incs;
+    undef @modules;
+#
+# Loop over other directories other than present ...
+
+      $scalar=@prereqs."";
+      $remains=join(" ",@prereqs);
+      until ( $scalar eq 0 ) {
+        $new_name=shift(@prereqs);
+        $scalar=@prereqs."";
+        foreach $dir (@directories) {
+          chdir ".." ;
+          chdir $dir;
+          foreach $file (<*.F90 *.f90 *.F *.f *.c *.h>) {
+            ( $file_basename = $file )    =~ s/\.[f,F,c,h].*$//i;
+            if ( $new_name eq $file_basename ) {
+              open(FILE, $file) || warn "Cannot open $file: $!\n";
+              while (<FILE>) {
+                /^\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+                /^\s*#\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+                /^\s*use\s+([^\s,!]+)/i && push(@modules, &toLower($1));
+              }
+            }
+          }
+        }
+      }
+#
+# Append to prerequisites list
+
+      @reqlist=split(" ",$reqline);
+      foreach $newmod (@modules) {
+        push(@reqlist, $newmod."\.o");
+      }
+      foreach $newinc (@incs) {
+        push(@reqlist, $newinc);
+      }
+#
+# Sorting and elimination of doubly defined prerequisites
+
+      @reqlist = &uniq(sort(@reqlist));
+#
+# Write rule to Makefile_new
+
+      $rule=join(" ",@reqlist);
+      $allprereqs = $allprereqs.$rule." ";
+      $rule=$target.": ".$rule;
+      $target=$target.": ";
+      print DEPENDS "$target";
+      undef @incs;
+      &PrintWords(length($target) + 2, 0, @reqlist, @incs );
+      print DEPENDS "\n";
+    }
+  }
+
+#
+# Check whether new targets popped up ...
+
+@alltargets = &uniq(sort(@alltargets));
+
+@allprereqs = split (" ",$allprereqs);
+@allprereqs = &uniq(sort(@allprereqs));
+
+#
+# Subtract targets from list of all prerequisites
+
+     $count=@alltargets;
+     until ( ( $count == 0 ) || ( $#allprereqs == 0 ) ){
+
+       if ($allprereqs[0] eq $alltargets[0] ) {
+         $junk=shift (@alltargets);
+         $junk=shift (@allprereqs);
+       }
+
+       if ($allprereqs[0] gt $alltargets[0] ) {
+         $junk=shift (@alltargets);
+       }
+
+       if ($allprereqs[0] lt $alltargets[0] ) {
+         push(@prereqs_left,$allprereqs[0]);
+         $junk=shift (@allprereqs);
+       }
+       $count=@alltargets;
+
+     }
+
+#
+# If new targets popped up ...
+
+     $scalar=@prereqs_left.""; #26
+     $remains=join(" ",@prereqs_left);
+#     print "* Having $scalar new targets : $remains  \n";
+     until ( $scalar eq 0 ) {
+       $target=shift(@prereqs_left);
+#       print "* Target= $target\n";
+       $scalar=@prereqs_left."";
+       undef @modules;
+       undef @incs;
+       foreach $dir (@dirs) {
+         chdir ".." ;
+         chdir $dir;
+         foreach $file (<*.F90 *.f90 *.F *.f *.c *.h>) {
+           ( $file_basename = $file )    =~ s/\.[f,F,c,h].*$//;
+           ( $new_name = $target )    =~ s/\.[o,h]$//;
+             if ( $new_name eq $file_basename ) {
+               open(FILE, $file) || warn "Cannot open $file: $!\n";
+               while (<FILE>) {
+                 /^\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1);
+                 /^\s*#\s*include\s*["\']([^"\']+)["\']/i && push(@incs, $1.".h");
+                 /^\s*use\s+([^\s,!]+)/i && push(@modules, &toLower($1.".o"));
+               }
+             }
+         }
+         if ( defined @incs || defined @modules) {
+           @modules=&uniq(sort(@modules));
+           @incs=&uniq(sort(@incs));
+           $target=$target.": ";
+           print DEPENDS "$target";
+           &PrintWords(length($target) + 2, 0, @modules, @incs );
+           print DEPENDS "\n";
+           undef @modules;
+           undef @incs;
+         }
+       }
+     }
+
+close (DEPENDS);
+
+}
+############################################################################
+#
+# &PrintWords(current output column, extra tab?, word list); --- print words
+#    nicely
+#
+sub PrintWords {
+   local($columns) = 78 - shift(@_);
+   local($extratab) = shift(@_);
+   local($wordlength);
+   #
+   print DEPENDS @_[0];
+   $columns -= length(shift(@_));
+   foreach $word (@_) {
+      $wordlength = length($word);
+      if ($wordlength + 1 < $columns) {
+         print DEPENDS " $word";
+         $columns -= $wordlength + 1;
+         }
+      else {
+         #
+         # Continue onto a new line
+         #
+         if ($extratab) {
+            print DEPENDS " \\\n\t\t$word";
+            $columns = 62 - $wordlength;
+            }
+         else {
+            print DEPENDS " \\\n\t$word";
+            $columns = 70 - $wordlength;
+            }
+         }
+      }
+   }
+
+############################################################################
+#
+# &toLower(string); --- convert string into lower case
+#
+sub toLower {
+   local($string) = @_[0];
+   $string =~ tr/A-Z/a-z/;
+   $string;
+   }
+
+############################################################################
+#
+# &uniq(sorted word list); --- remove adjacent duplicate words
+#@others = &uniq(sort(@others)
+sub uniq {
+   local(@words);
+   foreach $word (@_) {
+      if ($word ne $words[$#words]) {
+         push(@words, $word);
+         }
+      }
+   @words;
+   }
+
+EOF
+
+chmod 755 ${scriptname}.pl 
+
+./${scriptname}.pl $scriptdirec "$1" "$2" $proctype
+
+rm ${scriptname}.pl
+
+exit
Index: CPL/oasis3/trunk/util/compile/frames/Create_COMP_cpl_models.ksh
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/Create_COMP_cpl_models.ksh	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/Create_COMP_cpl_models.ksh	(revision 1677)
@@ -0,0 +1,252 @@
+#! /bin/ksh
+#######################################################################
+#
+#
+#     Script to generate all component model compile scripts for
+#     a coupled PRISM constellation.
+#                                                                       
+#     File       : ~/util/compile/frames/Create_COMP_cpl_models.ksh
+#
+#     Stephanie Legutke, MPI-HH, M&D          Dec 14, 2004
+#
+#     This script calls the script for the generation of component model 
+#     for  all component models of a PRISM coupled model constellation.
+#     The compile script are specifically created for the target platform 
+#     specified in the third parameter ("": platform where the scripts are run;
+#     ("node": platform as specified).
+#     The node name is either detected with `uname -n` or, if the script is not 
+#     created on the target machine, it must be specified by the user. 
+#     The generated compile scripts are configured consistenly for the
+#     PRISM coupled model specified in the first parameter and tagged with
+#     a version/experiment ID (2nd parameter).
+#
+# Usage :
+#        Create_COMP_cpl_models.ksh 'coupled model name' [ID [node [MPI1/2]]]
+#           coupled model name (required) : see table on PRISM web site
+#           ID                 (optional) : tag/version/experiment ID
+#           node               (optional) : node name of compile server
+#           MPI1/2             (optional) : MPI message passing version
+#        
+#
+# Potential partner models for
+# mpi-om          : echam5 hamocc pisces ham
+# echam5          : hamocc ham mpi-om
+# hamocc          : echam5 ham mpi-om
+# ham             : echam5 hamocc mpi-om
+# arpege_climat4  : opa toyoce
+# lim             : opa toy4opa lmdz orchidee
+# mozart          : echam5 (not yet!)
+# opa             : lmdz arpege_climat4 lim orchidee toy4opa
+# pisces          : echam5 mpi-om
+# toy4opa         : opa lim mpi-om
+# toyatm          : toyche toyoce 
+# toyche          : toyatm toyoce 
+# toyoce          : toyatm toyche
+# lmdz            : orchidee opa lim
+# orchidee        : lmdz lim opa 
+#
+#######################################################################
+set +x
+set -e
+
+if [ "$1" = "" ] || [ "$1" = "--" ] || [ "$1" = "-help" ] || \
+   [ "$1" = "--help" ]; then
+   echo '    Usage :'
+   echo '      Create_COMP_cpl_models.ksh  cplmod [ID [node [MPI1/2]]]'
+   echo '                cplmod (required) : coupled model name' 
+   echo '                ID     (optional) : tag/version/experiment ID'
+   echo '                node   (optional) : node name of compile server'
+   echo '                MPI1/2 (optional) : MPI message passing version'
+   exit 1
+else
+   cpl_mod=$1
+   if [ ! "$2" = "" ];then
+      ID=$2
+   else
+      ID=""
+   fi
+   if [ ! "$3" = "" ];then
+      node=$3
+   else
+      node=""
+   fi
+   if [ ! "$4" = "" ];then
+      chan=$4
+   else
+      chan=""
+   fi
+fi
+
+# MPI-OM
+# ------
+if [ "$cpl_mod" = "mpi-o" ] || [ "$cpl_mod" = "mpi-om" ]; then
+   if [ "$2" = "" ];then
+      ID=B01
+   fi
+   ./Create_COMP_models.frm mpi-om NONE - "" "$node" "$ID" ""
+
+# MPI-OB
+# ------
+elif [ "$cpl_mod" = "mpi-ob" ]; then
+   if [ "$2" = "" ];then
+      ID=B03
+   fi
+   ./Create_COMP_models.frm hamocc NONE - "" "$node" "$ID" "mpi-om hamocc"
+   ./Create_COMP_models.frm mpi-om NONE - "" "$node" "$ID" "mpi-om hamocc"
+
+# MPI-O-PISCES
+# ------------
+elif [ "$cpl_mod" = "mpi-o-pisces" ]; then
+   if [ "$2" = "" ];then
+      ID=B02
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm pisces NONE - "" "$node" "$ID" "mpi-om pisces"
+  ./Create_COMP_models.frm mpi-om NONE - "" "$node" "$ID" "mpi-om pisces"
+
+# ECHAM5
+# ------
+elif [ "$cpl_mod" = "echam5" ]; then
+   if [ "$2" = "" ];then
+      ID=A01
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm echam5 NONE - "" "$node" "$ID" ""
+
+# MPI-AO (=ECHO)
+# --------------
+elif [ "$cpl_mod" = "mpi-ao" ] || [ "$cpl_mod" = "echo" ]; then
+   if [ "$2" = "" ];then
+      ID=D10
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3  "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm echam5  "$chan" - "" "$node" "$ID" "echam5 mpi-om"
+  ./Create_COMP_models.frm mpi-om  "$chan" - "" "$node" "$ID" "echam5 mpi-om"
+
+# MPI-AOB
+# -------
+elif [ "$cpl_mod" = "mpi-aob" ]; then
+   if [ "$2" = "" ];then
+      ID=D15
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3  "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm echam5  "$chan" - "" "$node" "$ID" "echam5 mpi-om hamocc"
+  ./Create_COMP_models.frm hamocc  "$chan" - "" "$node" "$ID" "echam5 mpi-om hamocc"
+  ./Create_COMP_models.frm mpi-om  "$chan" - "" "$node" "$ID" "echam5 mpi-om hamocc"
+
+# MPI-AO-PISCES
+# -------------
+elif [ "$cpl_mod" = "mpi-ao-pisces" ]; then
+   if [ "$2" = "" ];then
+      ID=D17
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3  "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm echam5  "$chan" - "" "$node" "$ID" "echam5 mpi-om pisces"
+  ./Create_COMP_models.frm mpi-om  "$chan" - "" "$node" "$ID" "echam5 mpi-om pisces"
+  ./Create_COMP_models.frm pisces  "$chan" - "" "$node" "$ID" "echam5 mpi-om pisces"
+
+# MPI-AOB-HAM
+# -----------
+elif [ "$cpl_mod" = "mpi-aob-ham" ]; then
+   if [ "$2" = "" ];then
+      ID=D16
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3  "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm echam5  "$chan" - "" "$node" "$ID" "echam5 ham mpi-om hamocc"
+  ./Create_COMP_models.frm hamocc  "$chan" - "" "$node" "$ID" "echam5 ham mpi-om hamocc"
+  ./Create_COMP_models.frm mpi-om  "$chan" - "" "$node" "$ID" "echam5 ham mpi-om hamocc"
+
+# MOZART
+#-------
+elif [ "$cpl_mod" = "mozart" ]; then
+   if [ "$2" = "" ];then
+      ID=C01
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm mozart  "$chan" - "" "$node" "$ID" "echam5"
+
+# IPSL-CM4
+#---------
+elif [ "$cpl_mod" = "ipsl_cm4" ]; then
+   if [ "$2" = "" ];then
+      ID=I01
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3   "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm lmdz     "$chan" - "" "$node" "$ID" "lmdz orchidee opa lim"
+  ./Create_COMP_models.frm orchidee "$chan" - "" "$node" "$ID" "lmdz orchidee opa lim"
+  ./Create_COMP_models.frm opa      "$chan" - "" "$node" "$ID" "lmdz orchidee opa lim"
+  ./Create_COMP_models.frm lim      "$chan" - "" "$node" "$ID" "lmdz orchidee opa lim"
+
+# OPATOY
+#-------
+elif [ "$cpl_mod" = "opatoy" ]; then
+   if [ "$2" = "" ];then
+      ID=I00
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3       "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm opa          "$chan" - "" "$node" "$ID" "opa lim toy4opa"
+  ./Create_COMP_models.frm lim          "$chan" - "" "$node" "$ID" "opa lim toy4opa"
+  ./Create_COMP_models.frm toy4opa      "$chan" - "" "$node" "$ID" "opa lim toy4opa"
+
+# TOYCLIM
+#---------
+elif [ "$cpl_mod" = "toyclim" ]; then
+   if [ "$2" = "" ];then
+      ID=ID
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3 "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm toyatm "$chan" - "" "$node" "$ID" "toyatm toyoce toyche"
+  ./Create_COMP_models.frm toyoce "$chan" - "" "$node" "$ID" "toyatm toyoce toyche"
+  ./Create_COMP_models.frm toyche "$chan" - "" "$node" "$ID" "toyatm toyoce toyche"
+
+# ARPEGETOY
+#----------
+elif [ "$cpl_mod" = "arpegetoy" ]; then
+   if [ "$2" = "" ];then
+      ID=M00
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3         "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm toy4arpege     "$chan" - "" "$node" "$ID" "arpege_climat4 toy4arpege"
+  ./Create_COMP_models.frm arpege_climat4 "$chan" - "" "$node" "$ID" "arpege_climat4 toy4arpege"
+
+# ARPEGE-ORCA
+#------------
+elif [ "$cpl_mod" = "arpege-orca" ]; then
+   if [ "$2" = "" ];then
+      ID=M01
+   fi
+  ./Create_COMP_libs.frm   - "" "$node" "$chan"
+  ./Create_COMP_models.frm oasis3         "$chan" - "" "$node" " " ""
+  ./Create_COMP_models.frm lim            "$chan" - "" "$node" "$ID" "arpege_climat4 opa lim"
+  ./Create_COMP_models.frm opa            "$chan" - "" "$node" "$ID" "arpege_climat4 opa lim"
+  ./Create_COMP_models.frm arpege_climat4 "$chan" - "" "$node" "$ID" "arpege_climat4 opa lim"
+
+# unknown model
+# -------------
+else
+  echo "The coupled model specified is not supported"
+  echo "   Supported coupled models are:"
+  echo "      arpegetoy       : ARPEGE TOY4ARPEGE "
+  echo "      arpege-orca     : ARPEGE OPA "
+  echo "      echo (=mpi-ao)  : ECHAM5 MPI-OM " 
+  echo "      ipsl_cm4        : LMDZ ORCHIDEE OPA LIM "
+  echo "      mozart          : MOZART "
+  echo "      mpi-ao (=echo)  : ECHAM5 MPI-OM "
+  echo "      mpi-aob         : ECHAM5 MPI-OM HAMOCC "
+  echo "      mpi-ao-pisces   : ECHAM5 MPI-OM PISCES "
+  echo "      mpi-aob-ham     : ECHAM5 MPI-OM HAMOCC (HAM)"
+  echo "      mpi-om (=mpi-o) : MPI-OM "
+  echo "      mpi-ob          : MPI-OM HAMOCC "
+  echo "      mpi-o-pisces    : MPI-OM PISCES "
+  echo "      opatoy          : OPA TOY4OPA "
+  echo "      toyclim         : TOYATM TOYCHE TOYOCE "
+
+fi
Index: CPL/oasis3/trunk/util/compile/frames/Create_COMP_libs.frm
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/Create_COMP_libs.frm	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/Create_COMP_libs.frm	(revision 1677)
@@ -0,0 +1,318 @@
+#! /bin/ksh
+################################################################################
+#
+#     File       : ~/util/compile/frames/Create_COMP_libs.frm
+#                                                                       
+#     Script to generate the library compile script
+#
+#     Stephanie Legutke, MPI-HH, M&D          Dec 14, 2004
+#
+#     This script is used to generate a compile script for the PRISM libraries.
+#     The script is specifically created for the target platform.
+#     Depending on the node name it selects site and OS specifics.
+#     The node name is either detected with `uname -n` or, if the script is not 
+#     created on the target machine, it must be specifieid by the user. 
+#     The generated compile script is moved to ~/src/mod/'model name' 
+#     after successful generation.
+#     The script uses m4 for preprocessing. It has been tested with 
+#     GNU m4 version 1.4. Other, older or non-GNU versions of m4 may fail!
+#
+#     This script is called interactively only.
+#
+#     5 positional parameters are possible:
+#
+#     Usage : COMP_libs [- [- [node [MPI1]]]]
+#
+#        $1=""/"-":           directing std output to a file / the screen
+#        $2=""/"-"/"+":       directing err output to a file / the screen / stdout
+#        $3=""/"'node'":      node name for header files with OS/site specs
+#        $4=""/"MPI1":        message passing
+#
+#     If not called with all parameters, the defaults are:
+#                 $1 the gmake of the generated script directs stdout to a file
+#                 $2 the gmake of the generated script directs errout to a file
+#                 $3 node name of the machine where this scripts is run;
+#                    (if it is not the node name appearing in the header file 
+#                    names with the site/OS specifications, it must be given)
+#                 $4 MPI2
+#            
+################################################################################
+#     
+  echo 
+  echo '-----------------------------------------------------------------'
+  echo ' '
+  echo ' This script may fail if you do not use the right version of m4!'
+if [ "$3" = "rhodes" ] ; then
+  echo ' The version you use is :' `/usr/freeware/bin/m4 --version`
+elif [ "$3" = "zahir" ] ; then
+  echo ' The version you use is :' `/usr/local/bin/m4 --version`
+elif [ "$3" = "vargas" ] ; then
+  echo ' The version you use is :' `/usr/local/pub/M4/m4-1.4.11/bin/m4 --version`
+else
+  echo ' The version you use is :' `m4 --version`
+fi
+  echo ' Make sure this is GNU m4 younger than version 1.4!'
+  echo ' '
+  echo '-----------------------------------------------------------------'
+
+set +x
+
+if [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '----------- Usage --------------------------------------------------------'
+  echo ' $1=""/"-":           directing std output to a file / the screen'
+  echo ' $2=""/"-"/"+":       directing err output to a file / the screen / stdout'
+  echo ' $3=""/"node":        node name for header files with OS/site specs'
+  echo ' $4=""/"MPI1":        message passing'
+  echo '--------------------------------------------------------------------------'
+  echo ' '
+  exit
+fi
+echo 
+
+#
+# Redirecting standard output and error output
+#
+
+outout='stdout=$SCRIPTDIR/COMP_libs.log'
+if [ "$1" != "" ]; then
+  if [ "$1" = "-" ]; then
+    outout='stdout=`tty`'
+    echo '* (g)make standard output will directed to screen.'
+  else
+    echo 'This values is not allowed for parameter 1 (std out)'
+    exit
+  fi
+else
+  echo '* (g)make standard output will be directed to a file.'
+fi
+
+errout='stderr=$SCRIPTDIR/COMP_libs.err'
+if [ "$2" != "" ]; then
+  if [ "$2" = "-" ]; then
+    echo '* (g)make standard error will directed to screen.'
+    errout='stderr=`tty`'
+  elif [ "$2" = "+" ]; then
+    echo '* (g)make standard error will directed to stdout.'
+    errout='stderr="$stdout"'
+  else
+    echo 'This values is not allowed for parameter 2 (std err)'
+    exit
+  fi
+else
+  echo '* (g)make standard error will be directed to a file.'
+fi
+
+#
+#  HOST, OS, node name for header file directory selection
+#
+
+node=`uname -n`
+node1_7=`echo ${node} | cut -c1-7`
+if [ ${node1_7} = platine ]; then node=${node1_7}; fi
+if [ ${node1_7} = mercure ]; then node=${node1_7}; fi
+node1_5=`echo ${node} | cut -c1-5`
+if [ ${node1_5} = zahir ]; then node=${node1_5}; fi
+if [ ${node1_5} = curie ]; then node=${node1_5}; fi
+node1_6=`echo ${node} | cut -c1-6`
+if [ ${node1_6} = vargas ] || [ ${node1_6} = titane ]; then node=${node1_6}; fi
+
+build=`uname -s`
+if [ "$3" != "" ]; then
+  if [ "$3" != $node ]; then
+    echo ' '
+    echo 'Warning: the node name specified is not the node name of this machine'
+    echo 'Ensure that the site/OS specific header files exist.'
+    node=$3
+  fi
+fi
+
+echo ' '
+echo '* Creating library compile script'
+echo '         on/for a '$build ' platform with node name ' $node'.'
+echo ' '
+
+node1_4=`echo ${node} | cut -c1-4`
+if [ ${node1_4} = xbar ]; then node=${node1_4}; fi
+if [ ${node1_4} = hpca ]; then node=${node1_4}; fi
+
+node1_2=`echo ${node} | cut -c1-2`
+if [ ${node1_2} = ds ]; then node=${node1_2}; fi
+
+node1_6=`echo ${node} | cut -c1-6`
+if [ ${node1_6} = total1 ]; then node=${node1_6}; fi
+
+echo ' '
+echo '* Abbreviated node name is  ' $node'.'
+echo ' '
+
+mespas=irgendwas
+messpass=MPI2
+if [ "$4" != "" ]; then
+  if [ "$4" = MPI1 ] || [ "$4" = NONE ]  ; then
+    messpass=$4
+    mespas=MPI2
+  else
+    echo 'This  may not be specified:'$4
+    exit 1
+  fi
+  echo '* The message passing will be '$4'.'
+else
+  echo '* The message passing will be MPI2.'
+fi
+
+#
+#  Change to directory of script
+#
+
+scriptdir=`dirname $0`
+cd $scriptdir
+
+# /u/fj/mfuj/mfuj004/bin/m4" ; xbar
+
+cat > infile.m4 <<EOF 
+#! /bin/ksh
+changequote([{,}])dnl
+changecom
+dnl
+dnl  Embedding as batch  (not needed on all nodes)
+dnl
+define(comp_Model,comp_libs)dnl
+sinclude(include/Qsub_start_${node}.h)dnl
+undefine([{comp_Model}])dnl
+
+dnl
+dnl  Comments, usage, history
+dnl
+include(include/Comments_libs.h)dnl
+include(include/Comments_libs_frm.h)dnl
+
+dnl
+dnl  GUI input for all compile scripts
+dnl
+define(${mespas},${messpass})dnl
+include(include/Guispecif_all.h)dnl
+undefine([{${mespas}}])dnl
+
+dnl
+dnl  GUI input depending on model
+dnl
+include(include/Guispecif_libs.h)dnl
+
+dnl
+dnl  Command parameter input (scripting only)
+dnl
+include(include/Command_par_libs_frm.h)dnl
+include(include/Input_check_all_frm.h)dnl
+include(include/Input_check_libs_frm.h)dnl
+
+dnl
+dnl  Parameter renaming and printing
+dnl
+include(include/Print_par_all.h)dnl
+include(include/Print_par_libs.h)dnl
+
+scriptdir=\`dirname \$0\`
+cd \$scriptdir
+export SCRIPTDIR=\`pwd\`
+node=\`uname -n\`
+node1_7=\`echo \${node} | cut -c1-7\`
+if [ \${node1_7} = platine ]; then node=\${node1_7}; fi
+if [ \${node1_7} = mercure ]; then node=\${node1_7}; fi
+node1_5=\`echo \${node} | cut -c1-5\`
+if [ \${node1_5} = zahir ]; then node=\${node1_5}; fi
+if [ \${node1_5} = curie ]; then node=\${node1_5}; fi
+node1_6=\`echo \${node} | cut -c1-6\`
+if [ \${node1_6} = vargas ] || [ \${node1_6} = titane ]; then node=\${node1_6}; fi
+dnl
+dnl  HOST, OS, node name
+dnl
+include(include/Prolog_all.h)dnl
+include(include/Prolog_libs.h)dnl
+export TARFILE=libs_\`date +%y%m%d\`.tar
+
+dnl
+dnl  Site and OS specifics
+dnl
+include(include_${node}/Sitespecific_${node}.h)dnl
+include(include_${node}/Compile_mode_libs_${node}.h)dnl
+include(include_${node}/OSspecific_${node}.h)dnl
+
+dnl
+dnl  Non Site and OS dependent cpp flags
+dnl
+include(include/Cppflags_libs.h)dnl
+include(include/Cppflags_edit.h)dnl
+
+dnl
+dnl  Build the build
+dnl
+include(include/Build_dirs_libs.h)dnl
+
+dnl
+dnl  Create top level Makefile
+dnl
+include(include/Top_makefile_all.h)dnl
+define(NodeName,$node)dnl
+include(include/Top_makefile_libs.h)dnl
+undefine(NodeName)dnl
+
+define(outdev,${outout})dnl
+outdev
+undefine([{outdev}])dnl
+define(errdev,${errout})dnl
+errdev
+undefine([{errdev}])dnl
+
+if [ -f \$BLDROOT/lib.status ]; then rm \$BLDROOT/lib.status; fi
+
+dnl
+dnl  Make libaries
+dnl
+include(include/Make_libs.h)dnl
+
+dnl
+dnl  Print update status : scripting only
+dnl
+include(include/Status_libs_frm.h)dnl
+
+dnl
+dnl  Embedding as batch  (not needed on all nodes)
+dnl
+sinclude(include/Qsub_end_${node}.h)dnl
+
+exit
+
+m4exit
+
+EOF
+#
+# Run preprocessor: note the blank behind -D / -U
+#
+if [ "$3" = "rhodes" ] ; then
+  /usr/freeware/bin/m4 infile.m4 > COMP_libs
+elif [ "$3" = "zahir" ] ; then
+  /usr/local/bin/m4 infile.m4 > COMP_libs
+elif [ "$3" = "vargas" ] ; then
+  /usr/local/pub/M4/m4-1.4.11/bin/m4 infile.m4 > COMP_libs
+else
+  m4 infile.m4 > COMP_libs
+fi  
+
+status=$?
+if [ $status -eq 0 ]; then
+  mv COMP_libs ../../COMP_libs.${node}
+  chmod 755 ../../COMP_libs.${node}
+  olddir=`pwd`
+  cd ../..
+  moddir=`pwd`
+  echo "* The compile script name is "$moddir/COMP_libs.${node}
+  echo ' '
+else
+  echo "An error occurred! Status="$status
+  echo ' '
+fi
+
+cd $olddir
+rm infile.m4
+exit
Index: CPL/oasis3/trunk/util/compile/frames/Create_COMP_models.frm
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/Create_COMP_models.frm	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/Create_COMP_models.frm	(revision 1677)
@@ -0,0 +1,455 @@
+#! /bin/ksh
+################################################################################
+#
+#     Script to generate a component model compile script
+#                                                                       
+#     File       : ~/util/compile/frames/Create_COMP_models.frm
+#
+#     Stephanie Legutke, MPI-HH, M&D          Dec 14, 2004
+#
+#     This script is used to generate a compile script for a PRISM component model.
+#     The script is specifically created for the target platform.
+#     Depending on the node name it selects site and OS specifics.
+#     The node name is either detected with `uname -n` or, if the script is not 
+#     created on the target machine, it must be specifieid by the user. 
+#     The generated compile script is moved to ~/src/mod/'modelname' 
+#     after successful generation.
+#     The script uses m4 for preprocessing. It has been tested with 
+#     GNU m4 version 1.4. Other, older or non-GNU versions of m4 may fail!
+#
+#     This script is called interactively only.
+#
+#     7 positional parameters :
+#
+#     Usage : Create_COMP_models.frm \
+#             'model_name'           \
+#             [message_passing [std out [std err [node[version[partner models]]]]]]
+#
+#	 $1='model_name'         (required)
+#        $2=""/"MPI1"/"NONE"     message passing
+#        $3=""/"-"               directing std output to a file / the screen
+#        $4=""/"-"/"+"           directing err output to a file / the screen / stdout
+#        $5=""/"'node'"          node name for header files with OS/site specs
+#        $6=""/"'version'"       version acronym for differentiation of executables
+#        $7=""/"partner models"  models of the coupled model constellation
+#
+#     If not called with all parameters, the defaults are:
+#        $2 MPI2
+#        $3 gmake directs stdout to a file
+#        $4 gmake directs stderr to a file
+#        $5 node name `uname -n` of the machine where the script is run
+#        $6 D10
+#        $7 " " (standalone)
+#                
+#
+#     Note: if the model has not yet been ported to a machine (specified by 
+#           node name) a message like: infile.m4:53: m4: Cannot open include/...
+#           for some model or machine dependent header file will be given.
+#           These files have to be provided then.
+#            
+################################################################################
+set +x
+
+if [ "$1" = "" ] || [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '--------------------------------------------------------------------------'
+  echo ' '
+  echo ' This script may fail if you do not use the right version of m4!'
+  if [ "$5" = "rhodes" ] ; then
+    echo ' The version you use is :' `/usr/freeware/bin/m4 --version`
+  elif [ "$5" = "zahir" ] ; then
+    echo ' The version you use is :' `/usr/local/bin/m4 --version`
+  elif [ "$5" = "vargas" ] ; then
+    echo ' The version you use is :' '`/usr/local/pub/M4/m4-1.4.11/bin/m4 --version`'
+  else
+    echo ' The version you use is :' `m4 --version`
+  fi
+  echo ' Make sure this is GNU m4 younger than version 1.4!'
+  echo ' '
+  echo '--------------------------------------------------------------------------'
+  echo '----------- Usage --------------------------------------------------------'
+  echo ' $1=model name                                                      (none)'
+  echo ' $2=""/"MPI1"/"NONE": message passing                               (MPI2)'
+  echo ' $3=""/"-": std output of compile script -> file / screen           (file)'
+  echo ' $4=""/"-"/"+": err output -> file / the screen / stdout            (file)'
+  echo ' $5=""/"node name": node name of compile server               (`uname -n`)'
+  echo ' $6="version acronym"                                               (none)'
+  echo ' $7="list of participating models"                                  (none)'
+  echo ''
+  echo ' Specification of defaults is not allowed: write e.g.'
+  echo '            Create_COMP_models.frm oasis3 "" - "" ""'
+  echo ' instead of'
+  echo '            Create_COMP_models.frm oasis3 "MPI2" - "" ""'
+  echo '--------------------------------------------------------------------------'
+  exit
+fi
+
+#
+#  Model names for header file selection
+#
+list_of_PRISM_models="arpege_climat4 echam5 hamocc ham lim lmdz mozart mpi-om oasis3 opa orchidee pisces psmodel toy4opa toyatm toyche toyoce toy4arpege"
+
+valid_model=no
+for spec_model in ${list_of_PRISM_models}; do
+  if [ "$1" = "$spec_model"  ]; then
+    valid_model=yes
+    model=$1
+  fi
+done 
+if [ "${valid_model}" = "no" ]; then
+  echo ' The model name is not a valid PRISM model: '$1
+  echo ' The script is stopped!'
+  exit 1
+fi
+
+#
+#  Model version
+#
+if [ "$6" = ""  ]; then
+  version=D10
+else
+  version=$6
+  echo "* "
+  echo "* Compile script for model $model, version=$version is created"
+fi
+
+#
+#  If no partner models are specified with cpl_to the standalone version is taken as default.
+#  This may not be possible for al models.
+#
+if [ "$7" = "" ] || [ "$7" = " " ]; then
+  cpl_to=" "
+else
+  for model1 in $7; do
+    valid_model=no
+    for model2 in ${list_of_PRISM_models}; do
+      if [ "$model1" = "$model2"  ]; then
+        valid_model=yes
+      fi 
+    done
+    if [ "${valid_model}" = "no" ]; then
+      echo ' One of the models names is not a valid PRISM model: ' $model1
+      echo ' The script is stopped!'
+      exit 1
+    fi
+  done
+  if [ "${valid_model}" = "yes" ]; then
+      cpl_to=$7
+      echo "* "
+      echo "* Partner component models are: ${cpl_to}"
+  fi
+fi
+#
+#  HOST, OS, node name for header selection
+#
+echo ' '
+node=`uname -n`
+node1_7=`echo ${node} | cut -c1-7`
+if [ ${node1_7} = platine ]; then node=${node1_7}; fi
+if [ ${node1_7} = mercure ]; then node=${node1_7}; fi
+node1_5=`echo ${node} | cut -c1-5`
+if [ ${node1_5} = zahir ]; then node=${node1_5}; fi
+if [ ${node1_5} = curie ]; then node=${node1_5}; fi
+node1_6=`echo ${node} | cut -c1-6`
+if [ ${node1_6} = vargas ] || [ ${node1_6} = titane ]; then node=${node1_6}; fi
+
+build=`uname -s`
+if [ "$5" != "" ] && [ "$5" != $node ]; then
+    echo ' '
+    echo Warning: the node specified is not the node of this machine.
+    echo Ensure that the site/OS specific header files exist.
+    node=$5
+    build=""
+    echo '* Creating compile script'
+    echo '           for ' $model'.'
+else
+  echo '* Creating compile script'
+  echo '           on/for a '$build ' platform with node name ' $node','
+  echo '           for ' $model'.'
+fi
+
+node1_4=`echo ${node} | cut -c1-4`
+if [ ${node1_4} = xbar ]; then node=${node1_4}; fi
+if [ ${node1_4} = hpca ]; then node=${node1_4}; fi
+
+node1_2=`echo ${node} | cut -c1-2`
+if [ ${node1_2} = ds ]; then node=${node1_2}; fi
+
+node1_6=`echo ${node} | cut -c1-6`
+if [ ${node1_6} = total1 ]; then node=${node1_6}; fi
+
+echo '* Abbreviated node name is ' $node'.'
+
+#
+# Checking consistency of message passing parameter and model
+#
+mespas=irgendwas
+messpass=MPI2
+if [ "$2" != "" ];  then
+
+if [ "$2" = "MPI1" ] || [ "$2" = "NONE" ]; then
+  if [ "$2" = "MPI1" ] ; then
+    if [ "$model"  = "echam5" ] ||
+       [ "$model"  = "mpi-om" ] ||
+       [ "$model"  = "hamocc" ] ||
+       [ "$model"  = "pisces" ] ||
+       [ "$model"  = "psoce"  ]    ; then 
+       echo 'MPI1 for '$model' is not possible.'
+       exit 1
+     else
+       messpass=$2
+       mespas=MPI2    
+     fi
+  fi
+  if [ "$2" = "NONE" ] ; then
+    if [ "$model"  = ""       ]    ; then 
+       echo 'NONE for '$model' is not possible.'
+       exit 1
+     else
+       messpass=$2
+       mespas=MPI2    
+     fi
+  fi
+else
+  echo 'ERROR:This message passing may not be specified:'$2
+  exit 1
+fi
+
+fi
+echo '* The message passing will be '$messpass'.'
+
+#
+# Redirecting standard output and err output
+#
+outout='stdout=$SCRIPTDIR/COMP_${MODEL_DIR}.log'
+if [ "$3" != "" ]; then
+  if [ "$3" = "-" ]; then
+    outout='stdout=`tty`'
+    echo '* (g)make standard output will directed to screen.'
+  else
+    echo 'This values is not allowed for parameter 3 (std out)'
+    exit
+  fi
+else
+  echo '* (g)make standard output will be directed to a file.'
+fi
+errout='stderr=$SCRIPTDIR/COMP_${MODEL_DIR}.err'
+if [ "$4" != "" ]; then
+  if [ "$4" = "-" ]; then
+    echo '* (g)make standard error will directed to screen.'
+    errout='stderr=`tty`'
+  elif [ "$4" = "+" ]; then
+    echo '* (g)make standard error will directed to stdout.'
+    errout='stderr="$stdout"'
+  else
+    echo 'This values is not allowed for parameter 4 (std err)'
+    exit
+  fi
+else
+  echo '* (g)make standard error will be directed to a file.'
+fi
+
+#
+#  Change to directory of script
+#
+
+scriptdir=`dirname $0`
+cd $scriptdir
+
+# /u/fj/mfuj/mfuj004/bin/m4  ; xbar
+
+cat > infile.m4 <<EOF 
+#! /bin/ksh
+changequote([{,}])dnl
+changecom
+dnl
+dnl  Embedding as batch  (not needed on all nodes)
+dnl
+define(comp_Model,comp_${model})dnl
+sinclude(include_${node}/Qsub_start_${node}.h)dnl
+undefine([{comp_Model}])dnl
+
+dnl
+dnl  Comments, usage, history
+dnl
+define(comp_Model,${model})dnl
+define(COMP_comp_Model,COMP_${model})dnl
+include(include/Comments_models.h)dnl
+include(include/Comments_models_frm.h)dnl
+undefine([{comp_Model}])dnl
+undefine([{COMP_comp_Model}])dnl
+
+scriptdir=\`dirname \$0\`
+cd \$scriptdir
+export SCRIPTDIR=\`pwd\`
+node=\`uname -n\`
+node1_7=\`echo \${node} | cut -c1-7\`
+if [ \${node1_7} = platine ]; then node=\${node1_7}; fi
+if [ \${node1_7} = mercure ]; then node=\${node1_7}; fi
+node1_5=\`echo \${node} | cut -c1-5\`
+if [ \${node1_5} = zahir ]; then node=\${node1_5}; fi
+if [ \${node1_5} = curie ]; then node=\${node1_5}; fi
+node1_6=\`echo \${node} | cut -c1-6\`
+if [ \${node1_6} = vargas ] || [ \${node1_6} = titane ]; then node=\${node1_6}; fi
+
+dnl
+dnl  HOST, OS, node name ( <libprolog_oasis3.h>)
+dnl
+include(include/Prolog_all.h)dnl
+include(include/Prolog_models.h)dnl
+export TARFILE=\${MODEL_DIR}_\`date +%y%m%d\`.tar
+
+dnl
+dnl  GUI input for all compile scripts
+dnl
+changecom(#)
+define(${mespas},${messpass})dnl
+include(include/Guispecif_all.h)dnl
+undefine([{${mespas}}])dnl
+changecom
+
+dnl
+dnl  GUI input for all model compile scripts
+dnl
+changecom(#)
+define(Invalid_model,"${cpl_to}")dnl
+include(include/Guispecif_models.h)dnl
+undefine([{Invalid_model}])dnl
+changecom
+
+dnl
+dnl  GUI input depending on model
+dnl
+changecom(#)
+define(_ModVers,_${version})dnl
+include(include/Guispecif_${model}.h)dnl
+undefine([{_ModVers}])dnl
+sinclude(include/Guispecif_${model}_frm.h)dnl
+changecom
+
+dnl
+dnl  Command parameter input (scripting only)
+dnl
+include(include/Command_par_models_frm.h)dnl
+include(include/Input_check_all_frm.h)dnl
+
+dnl
+dnl  Parameter renaming and printing
+dnl
+include(include/Print_par_all.h)dnl
+include(include/Print_par_models.h)dnl
+include(include/Print_par_${model}.h)dnl
+
+dnl
+dnl  Site and OS specifics
+dnl
+include(include_${node}/Sitespecific_${node}.h)dnl
+include(include_${node}/Compile_mode_${model}_${node}.h)dnl
+include(include_${node}/OSspecific_${node}.h)dnl
+
+dnl
+dnl  Non Site and OS dependent cpp flags
+dnl
+include(include/Cppflags_${model}.h)dnl
+include(include/Cppflags_edit.h)dnl
+
+dnl
+dnl  Name of executabele
+dnl
+include(include/Execname.h)dnl
+
+dnl
+dnl  Libraries and directories
+dnl
+include(include/Libraries_${model}.h)dnl
+include(include/Libraries_models.h)dnl
+include(include/Build_dirs_models.h)dnl
+
+dnl
+dnl  Check library update status : scripting only
+dnl
+include(include/Check_libs.h)dnl
+
+dnl
+dnl  Additional update conditions
+dnl
+sinclude(include/Add_cond_${model}.h)dnl
+
+dnl
+dnl  Create top level Makefile
+dnl
+include(include/Top_makefile_all.h)dnl
+define(NodeName,$node)dnl
+include(include/Top_makefile_models.h)dnl
+undefine(NodeName)dnl
+
+define(outdev,${outout})dnl
+outdev
+undefine([{outdev}])dnl
+define(errdev,${errout})dnl
+errdev
+undefine([{errdev}])dnl
+
+if [ -f \$BLDROOT/${model}.status ]; then rm \$BLDROOT/${model}.status; fi
+
+dnl
+dnl  Make model 
+dnl
+include(include/Make_model.h)dnl
+
+dnl
+dnl  Print update status : scripting only
+dnl
+include(include/Status_mods_frm.h)dnl
+
+dnl
+dnl  Save/rename the executable
+dnl
+include(include/Save_exec.h)dnl
+
+dnl
+dnl  Embedding as batch  (not needed on all nodes)
+dnl
+sinclude(include_${node}/Qsub_end_${node}.h)dnl
+exit
+m4exit
+
+EOF
+
+#
+# Run m4.
+#
+
+if [ "$5" = "rhodes" ] ; then 
+  /usr/freeware/bin/m4 infile.m4 > COMP_${model} 
+elif [ "$5" = "zahir" ] ; then
+  /usr/local/bin/m4 infile.m4 > COMP_${model} 
+elif [ "$5" = "vargas" ] ; then
+  /usr/local/pub/M4/m4-1.4.11/bin/m4 infile.m4 > COMP_${model}
+else
+  m4 infile.m4 > COMP_${model}
+fi  
+
+status=$?
+if [ $status -eq 0 ]; then
+  if [ ! ${model} = "oasis3" ]; then
+    Compile_script=COMP_${model}_$6.${node}
+  else
+    Compile_script=COMP_${model}_${messpass}.${node}
+  fi
+  mv COMP_${model} ../../../src/mod/${model}/${Compile_script}
+  chmod 755 ../../../src/mod/${model}/${Compile_script}
+  olddir=`pwd`
+  cd ../../../src/mod/${model}
+  moddir=`pwd`
+  echo "* The model directory is " $moddir
+  echo "* The compile script name is "$moddir/${Compile_script}
+  echo ' '
+else
+  echo "An error occurred! Status="$status
+  echo ' '
+fi
+cd $olddir
+rm infile.m4
+
+exit 
Index: CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_libs.h	(revision 1677)
@@ -0,0 +1,30 @@
+################################# Directories   ################################
+# 
+# Container 'Build the build' : make build directories if needed
+#
+
+libs=${BLDROOT}/lib
+[ -d $libs ] || mkdir -p $libs
+
+lib=${BLDROOT}/build/lib
+
+BLDLIBS=" "
+bldlib=""
+for library in $srclibs; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    bldlib=${library}.${CHAN}
+  else
+    bldlib=${library}
+  fi  
+  if [ ! -d ${lib}/$bldlib  ]; then
+    echo 'Making build directory '${lib}/$bldlib' ...'
+    mkdir -p ${lib}/$bldlib
+  fi
+  ${cp} -p ${SRCROOT}/src/lib/$library/src/Makefile ${lib}/$bldlib
+  BLDLIBS=${BLDLIBS}" "$bldlib
+done
+export BLDLIBS
+
+cd ${lib}/$bldlib
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Build_dirs_models.h	(revision 1677)
@@ -0,0 +1,79 @@
+################################# Directories   ################################
+# 
+# Make the 'build' directories if needed
+#
+
+echo " "
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  echo The model $MODEL_DIR will be updated
+  if [ "${srclibs}" != " " ]; then
+    echo together with its libraries
+    echo $srclibs '.'
+  else 
+    echo No libraries need to be updated.
+  fi
+fi
+
+if [ ! -d ${BLDROOT}/lib/$MODEL_DIR ]; then
+  echo ' '
+  echo 'Making model library build directory '${BLDROOT}/lib/$MODEL_DIR
+  mkdir -p ${BLDROOT}/lib/$MODEL_DIR
+fi
+
+export MODBUILD=${BLDROOT}/build/mod/${MODEL_DIR}${MODVERS}
+if [ ${CHAN} != "NONE" ]; then
+  MODBUILD=${MODBUILD}.${CHAN}
+fi
+if [ ! -d $MODBUILD ]; then
+  echo ' '
+  echo 'Making build directory '$MODBUILD 
+  mkdir -p $MODBUILD 
+fi
+
+export bin=${BLDROOT}/bin
+[ -d $bin ] || mkdir -p $bin
+
+export OTHLIBS=" "
+if [ "$srclibs" != " "  ]; then
+for library in $srclibs ; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    ldlib=${library}.${CHAN}
+  else
+    ldlib=${library}
+  fi  
+  OTHLIBS=${OTHLIBS}" -l"$ldlib
+done
+OTHLIBS="-L${BLDROOT}/lib ${OTHLIBS}"
+fi
+
+export MODLIBS=" "
+for library in $MODLIB ; do
+  MODLIBS=${MODLIBS}" -l"${library}
+done
+MODLIBS="-L${BLDROOT}/lib/${MODEL_DIR} ${MODLIBS}"
+
+if [ "${SUBMOD1}" != ""  ]; then
+  MODLIBS=${MODLIBS}" -L${BLDROOT}/lib/${SUBMOD1} -l${SUBMOD1LIB}"
+  SUBMOD1LIB=lib${SUBMOD1LIB}.a
+fi
+
+#
+# Dont put paths here; they are included in VPATH
+#
+export DEPLIBS=" "
+for library in $MODLIB $srclibs ; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    ldlib=${library}.${CHAN}
+  else
+    ldlib=${library}
+  fi  
+  DEPLIBS=${DEPLIBS}" lib"${ldlib}.a
+done
+
+cd $MODBUILD
+if [ "$MAKETARGET" != "tar" ]; then
+  echo ' '
+  echo 'Build directory is '$MODBUILD
+fi
Index: CPL/oasis3/trunk/util/compile/frames/include/Check_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Check_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Check_libs.h	(revision 1677)
@@ -0,0 +1,70 @@
+#
+# Update external libraries
+#
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  if [ "$srclibs" != " " ]; then 
+    echo ' '
+    echo 'Checking the libraries ...'
+    if [ ! -f  $SRCROOT/util/COMP_libs.${NODE} ]; then
+      echo --- $SRCROOT/util/COMP_libs.${NODE} must be created first! ---
+      echo --- Use $SRCROOT/util/compile/frames/Create_COMP_libs.frm. ---
+      echo --- This script is stopped!
+      exit 1
+    fi
+    COMP_libs.${NODE} "all" "${srclibs}" "${CHAN}" "${MODEL_DIR}"
+    echo 'Checking the libraries finished '
+    echo ' '
+    echo ' '
+    echo 'Library update exit status : '
+    cat $BLDROOT/lib.status
+    set +e
+    grep -v ': 0' $BLDROOT/lib.status
+    if [ $? != 0 ]; then
+      echo 'Libraries OK'
+      echo ' '
+    else
+      echo "ERROR in $SRCROOT/util : Libraries not updated!"
+      echo "Check the log file for details!"
+      echo ' '
+      exit 1
+    fi
+    rm $BLDROOT/lib.status
+    set -e
+  fi
+fi
+
+#
+# Update submodel
+#
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "clean" ]; then 
+  if [ "${SUBMOD1}" != ""  ]; then 
+    echo ' '
+    echo 'Checking the submodel '${SUBMOD1}
+    COMP_submodel=$SRCROOT/src/mod/${SUBMOD1}/COMP_${SUBMOD1}${MODVERS}.${NODE}
+    if [ ! -f ${COMP_submodel} ]; then
+      echo --- ${COMP_submodel} must be created first! ---
+      echo --- Use $SRCROOT/util/compile/frames/Create_COMP_models.frm. ---
+      echo --- This script is stopped!
+      exit 1
+    fi
+    cpl_to=${cpl_to}" "${MODEL_DIR}
+    ${COMP_submodel} "${MAKETARGET}" "${CHAN}"
+    echo 'Checking the submodel finished '
+    echo ' '
+    echo 'Submodel update exit status : '
+    cat $BLDROOT/${SUBMOD1}.status
+    set +e
+    grep -v ': 0' $BLDROOT/${SUBMOD1}.status
+    if [ $? != 0 ]; then
+      echo 'Submodel '${SUBMOD1}' OK'
+      echo ' '
+    else
+      echo "ERROR in $SRCROOT/src/mod/${SUBMOD1} : Submodel not updated!"
+      echo "Check the log file for details!"
+      echo ' '
+      exit 1
+    fi
+    rm $BLDROOT/${SUBMOD1}.status
+    set -e
+  fi  
+fi
Index: CPL/oasis3/trunk/util/compile/frames/include/Command_par_libs_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Command_par_libs_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Command_par_libs_frm.h	(revision 1677)
@@ -0,0 +1,36 @@
+######################## Command line parameter  ###############################
+# 
+# Help function
+#
+if [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '----------- Usage -----------------------------------------------'
+  echo ' $1=make_target       (all/tar/clean; optional)'
+  echo ' $2=list_of_libraries (anaisg/anaism/clim/etc.; optional)'
+  echo ' $3=message_passing   (NONE/MPI1/MPI2; optional)'
+  echo ' '
+  echo ' Default active values are:'
+  echo ' make_target       : '${make_target}
+  echo ' list_of_libraries : '${list_of_libraries}
+  echo ' message_passing   : '${message_passing}
+  echo '-----------------------------------------------------------------'
+  exit 1
+fi
+
+# Overwrite with command line parameter if specified
+
+[ "$1" = "" ] || make_target=$1
+[ "$3" = "" ] || message_passing=$3
+#
+# if no message passing is specified, only compile the interpolation libraries
+#
+
+if [ ${message_passing} = "NONE" ]; then
+  list_of_libraries=" anaisg anaism fscint scrip"
+fi
+
+[ "$2" = "" ] || list_of_libraries=$2
+
+set -u
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Command_par_models_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Command_par_models_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Command_par_models_frm.h	(revision 1677)
@@ -0,0 +1,25 @@
+######################## Command line parameter  ###############################
+# 
+# Help function
+#
+if [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '----------- Usage -----------------------------------------------'
+  echo ' $1=make_target       (all/lib/tar/clean; optional)'
+  echo ' $2=message_passing   (MPI1/MPI2; optional)'
+  echo ' '
+  echo ' Default active values are:'
+  echo ' make_target               : '${make_target}
+  echo ' message_passing           : '${message_passing}
+  echo ' '
+  echo '-----------------------------------------------------------------'
+  exit 1
+fi
+
+# Overwrite with command line parameter if specified
+
+[ "$1" = "" ] || make_target=$1
+[ "$2" = "" ] || message_passing=$2
+
+set -u
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Comments_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Comments_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Comments_libs.h	(revision 1677)
@@ -0,0 +1,20 @@
+################################################################################
+#
+#     C O M P I L E  -  script for maintaining PRISM libraries.
+#                                                                       
+#     File       : ~/util/COMP_libs
+#
+#     This script is used to compile or clean any PRISM library.
+#     This include libraries used exclusively in any of the models
+#     or those used by the coupler only, or those shared by the models.
+#     
+#     When needed, different versions of the libraries are created.
+#     At the moment these are MPI1/MPI2 libraries.  
+#     
+#     This script is called directly by the administrator or SMS
+#     or by the model's compile scripts (on scripting level).
+#     When called by the model's compile scripts it checks and updates 
+#     the libraries needed to compile the models and only those.
+#     
+################################################################################
+#
Index: CPL/oasis3/trunk/util/compile/frames/include/Comments_libs_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Comments_libs_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Comments_libs_frm.h	(revision 1677)
@@ -0,0 +1,16 @@
+#     4 positional parameters are possible:
+#		 	        $1=make_target       (optional)
+#				$2=list_of_libraries (optional)
+#    		 	        $3=message_passing   (optional)
+#		 	        $4=calling_model     (optional)
+#
+#     Usage : COMP_libs        ["make_target" ["list_of_libraries" \
+#                              ["message_passing"  \
+#                              ["calling_model"]]]]
+#
+#     If called with no parameters, the defaults given below
+#     are used. If parameter n is specified; the parameter 1,...n-1
+#     must be specified as well.
+#     Note: parameter 4 is not used on the scripting level.
+#
+################################################################################
Index: CPL/oasis3/trunk/util/compile/frames/include/Comments_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Comments_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Comments_models.h	(revision 1677)
@@ -0,0 +1,6 @@
+#########################################################################
+#
+#     C O M P I L E  -  script for component model 'comp_Model'.
+#                                                                       
+#     File       : ~/src/mod/comp_Model/COMP_comp_Model
+#
Index: CPL/oasis3/trunk/util/compile/frames/include/Comments_models_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Comments_models_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Comments_models_frm.h	(revision 1677)
@@ -0,0 +1,48 @@
+#     2 positional parameters are possible:
+#	                        $1=Make target       (optional:all,lib,clean,tar)
+#    		 	        $2=message_passing   (optional)
+#
+#     message_passing "NONE" will cause the script NOT to update and load the 
+#     psmile/mpp_io libraries. It should therefore be used for creation of
+#     executables w/o submodels which do not communicate through OASIS3.
+#     For communication through OASIS3 use "MPI1" or "MPI2".
+#
+#     If called with $1=clean, only the model's build directory
+#     is cleaned, not the libraries.
+#
+#     If called with $1=lib, only the model's library (archive with .o files)
+#     is updated.
+#
+#     If called with $1=tar, a tar file with the source code of the model 
+#     and all libraries it links to is created. The tar file is moved to 
+#     PRISM source-root directory. 
+#
+#     If called with $1=all, this script checks all libraries needed by 
+#     the model. If these are not up-to-date they will be made by calling  
+#     the library-compile script with "all" for the target
+#                                with       the models libraries,
+#                                with       the message passing used by the model,
+#                                with       the model name
+#     as positional parameters to that script.
+#     If the libraries are ok the model will be made.
+#     
+#     The list of models being part of the coupled constellation (cpl_to) 
+#     is used to set the right cpp flags if needed. It is checked against
+#     a list of models that may be specified.
+#     For a standalone model specify " " (blank).
+#     For main models: 
+#     If the list of models being part of the coupled constellation (cpl_to)
+#     contains the name of a valid submodel the library with the source
+#     code of that submodel is created first.
+#
+#     Cleaning of libraries is not possible with this script.
+#
+#     Usage : COMP_comp_Model \
+#                        ["make_target"  ["message_passing" ] ]
+#
+#     If called with no parameters, the defaults given below
+#     are used. If parameter n is specified; the parameter 1,...n-1
+#     must be specified as well.
+#
+#########################################################################
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Cppflags_edit.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Cppflags_edit.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Cppflags_edit.h	(revision 1677)
@@ -0,0 +1,20 @@
+export CPPFLAGCC=$CPPFLAG
+
+CPPFLAGF90=""
+for flag in $CPPFLAG ; do
+ CPPFLAGF90=$CPPFLAGF90$CPPFLAGSEP$flag
+done
+if [ "$CPPFLAGF90" != "" ]; then 
+  CPPFLAGF90=$CPPFLAGF90start$CPPFLAGF90
+fi
+export CPPFLAGF90
+
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  echo ' '
+  echo "CPP flags used with the cc command: "
+  echo $CPPFLAGCC
+  echo ' '
+  echo "CPP flags used with the f90 command: "
+  echo $CPPFLAGF90
+fi
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Cppflags_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Cppflags_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Cppflags_libs.h	(revision 1677)
@@ -0,0 +1,16 @@
+################################################################################
+#
+# Libraries CPP flags not depending on site or OS
+#
+
+  CPPFLAG=$CPPFLAG" -Duse_comm_${CHAN} -Duse_libMPI"
+
+  if [ ${use_key_noIO} = yes ]; then 
+    CPPFLAG=$CPPFLAG" -Dkey_noIO"
+  fi
+  if [ ${use_NetCDF} = yes ]; then
+    CPPFLAG=$CPPFLAG" -Duse_netCDF"
+  fi
+
+  CPPFLAG=$CPPFLAG" -DNC_DOUBLE"
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Cppflags_oasis3.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Cppflags_oasis3.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Cppflags_oasis3.h	(revision 1677)
@@ -0,0 +1,7 @@
+################################################################################
+# 
+# OASIS3 CPP flags not depending on site or OS
+#
+
+CPPFLAG=${CPPFLAG}" -Duse_comm_${CHAN}"
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Execname.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Execname.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Execname.h	(revision 1677)
@@ -0,0 +1,14 @@
+#
+#--------------------------------------------------------------------------------
+# Model executable name.
+#
+
+export EXEC=${MODEL_DIR}
+if [ "${SUBMOD1}" != ""  ]; then
+  EXEC=${EXEC}_${SUBMOD1}
+fi
+EXEC=${EXEC}${MODVERS}
+if [ "${CHAN}" != "NONE"  ]; then
+  export EXEC=${EXEC}.${CHAN}
+fi
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Guispecif_all.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Guispecif_all.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Guispecif_all.h	(revision 1677)
@@ -0,0 +1,14 @@
+set -e
+
+################### Start of user specifications (defaults) ####################
+#
+
+# message_passing                       : NONE   /  MPI 2/1
+
+message_passing=MPI2
+
+# coupler                               : oasis3
+# use_key_noIO                          : whether mpp_io will be used for I/O
+# 
+coupler=oasis3
+use_key_noIO=no
Index: CPL/oasis3/trunk/util/compile/frames/include/Guispecif_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Guispecif_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Guispecif_libs.h	(revision 1677)
@@ -0,0 +1,11 @@
+# list_of_libraries  : any list of PRISM libraries possible
+# compile mode       : default/opt/..
+
+compile_mode=default
+
+use_NetCDF=yes
+
+list_of_libraries=" anaisg anaism clim fscint mpp_io psmile scrip"
+
+# make_target                           : clean/all/tar/lib
+make_target=all
Index: CPL/oasis3/trunk/util/compile/frames/include/Guispecif_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Guispecif_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Guispecif_models.h	(revision 1677)
@@ -0,0 +1,6 @@
+# Gui input for all models
+
+target_mode=forced                       : "" / forced
+target_mode=""
+
+cpl_to=Invalid_model
Index: CPL/oasis3/trunk/util/compile/frames/include/Guispecif_oasis3.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Guispecif_oasis3.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Guispecif_oasis3.h	(revision 1677)
@@ -0,0 +1,15 @@
+# OASIS3 specific GUI input:
+
+compile_mode=default
+
+model_version=""
+
+# make_target                           : clean/all/tar/lib
+make_target=all
+
+submodel_1=""
+
+#
+################### End of user specifications (defaults) ####################
+
+poss_cpl_mods=" "
Index: CPL/oasis3/trunk/util/compile/frames/include/Input_check_all_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Input_check_all_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Input_check_all_frm.h	(revision 1677)
@@ -0,0 +1,21 @@
+######################## Input checks : all  ########################
+# 
+#
+
+if [ "${make_target}" != "clean" ] && \
+   [ "${make_target}" != "all" ]   && \
+   [ "${make_target}" != "lib" ]   && \
+   [ "${make_target}" != "tar" ];       then 
+  echo " Invalid target : "${make_target}
+  echo " The task is stopped!"
+  exit 1
+fi
+
+if [ "${message_passing}" != "MPI2" ] && \
+   [ "${message_passing}" != "MPI1" ] && \
+   [ "${message_passing}" != "NONE" ];     then 
+  echo " Invalid option for message passing : "${message_passing}
+  echo " The task is stopped!"
+  exit 1
+fi
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Input_check_libs_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Input_check_libs_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Input_check_libs_frm.h	(revision 1677)
@@ -0,0 +1,25 @@
+######################## Input checks : libraries only  ########################
+# 
+
+for library in ${list_of_libraries}; do
+  if [ "${library}" != "anaisg" ]   && \
+     [ "${library}" != "anaism" ]   && \
+     [ "${library}" != "blas" ]     && \
+     [ "${library}" != "clim" ]     && \
+     [ "${library}" != "fscint" ]   && \
+     [ "${library}" != "ioipsl" ]   && \
+     [ "${library}" != "lapack" ]   && \
+     [ "${library}" != "linpack" ]   && \
+     [ "${library}" != "mpp_io" ]   && \
+     [ "${library}" != "netcdf90" ] && \
+     [ "${library}" != "psmile" ]   && \
+     [ "${library}" != "scrip" ]    && \
+     [ "${library}" != "libV4" ]    && \
+     [ "${library}" != "svipc" ]    && \
+     [ "${library}" != "support" ];       then 
+    echo " Invalid library : "${library}
+    echo " The task is stopped!"
+    exit 1
+  fi
+done
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Libraries_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Libraries_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Libraries_models.h	(revision 1677)
@@ -0,0 +1,32 @@
+#   SRCCOMP : model-src  directories in order they will be compiled      
+#   MODLIB : model  library/ies (should be one only)
+#   srclibs : other PRISM libraries ( $SRCROOT/src/lib...); must be " " if empty
+################################################################################
+# 
+# Libraries needed by all models
+#
+
+if [ "$MAKETARGET" = "all" ]; then
+if [ "$CHAN" != "NONE" ] && [ "${MODEL_DIR}" != "oasis3" ]; then 
+  srclibs=${srclibs}" psmile "
+  if [ $use_key_noIO != yes ]; then 
+    srclibs=${srclibs}" mpp_io"
+  fi
+fi
+fi
+
+################################################################################
+# 
+# Directories for tar file
+#
+
+TARFILE_DIRS=""
+for srclib in $srclibs; do
+ TARFILE_DIRS=${TARFILE_DIRS}" src/lib/${srclib}"
+done
+TARFILE_DIRS=${TARFILE_DIRS}" src/lib/psmile src/lib/mpp_io "
+if [ "${SUBMOD1}" != ""  ]; then
+  TARFILE_DIRS=${TARFILE_DIRS}" src/mod/${SUBMOD1}"
+fi
+export TARFILE_DIRS
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Libraries_oasis3.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Libraries_oasis3.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Libraries_oasis3.h	(revision 1677)
@@ -0,0 +1,15 @@
+################################################################################
+# 
+# Libraries for oasis3
+#
+
+export SRCCOMP="src"
+
+export MODLIB=$EXEC
+
+srclibs="anaisg anaism scrip fscint psmile mpp_io"
+if [ "$CHAN" != "NONE" ]; then
+  srclibs=${srclibs}" clim"
+fi
+
+export MAINPRG=couple
Index: CPL/oasis3/trunk/util/compile/frames/include/Make_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Make_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Make_libs.h	(revision 1677)
@@ -0,0 +1,19 @@
+################################################################################
+#
+# Execute makefile  :   -p : listing of all default rules
+#                       -d : debug
+#                       -k : dont stop when error occurs
+# 
+
+mv Top_Makefile_$$ ../Top_Makefile_$$
+
+if [ -f ${stdout} ] ; then
+   rm -f ${stdout}
+fi
+if [ -f ${stderr} ] ; then
+   rm -f ${stderr}
+fi
+
+make -f ../Top_Makefile_$$ $MAKETARGET -k
+
+rm ../Top_Makefile_$$
Index: CPL/oasis3/trunk/util/compile/frames/include/Make_model.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Make_model.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Make_model.h	(revision 1677)
@@ -0,0 +1,20 @@
+################################################################################
+#
+# Execute makefile  :   -p : listing of all default rules
+#                       -d : debug
+#                       -k : dont stop when error occurs
+# 
+
+if [ -f ${stdout} ] ; then
+   rm -f ${stdout}
+fi
+if [ -f ${stderr} ] ; then
+   rm -f ${stderr}
+fi
+
+make -f Top_Makefile_$$ $MAKETARGET -k
+  
+if [ ! "$MAKETARGET" = "clean" ]; then
+  rm Top_Makefile_$$
+fi
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Print_par_all.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Print_par_all.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Print_par_all.h	(revision 1677)
@@ -0,0 +1,11 @@
+######################## Set and print input parameter: all  ###################
+# 
+
+export COUPLER=${coupler}
+
+export MAKETARGET=${make_target}
+echo " "
+echo "Make target : "$MAKETARGET
+
+export CHAN=${message_passing}
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Print_par_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Print_par_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Print_par_libs.h	(revision 1677)
@@ -0,0 +1,28 @@
+######################## Set and print input parameters: libs  #################
+# 
+
+export srclibs=${list_of_libraries}
+echo " "
+if [ "$MAKETARGET" = "all" ]; then
+  echo "Libraries which will be updated :" 
+  echo $srclibs
+elif [ "$MAKETARGET" = "clean" ]; then
+  echo "Libraries which will be cleaned :" 
+  echo $srclibs
+elif [ "$MAKETARGET" = "tar" ]; then
+  echo "A tar-file of libraries will be created with:"
+  echo $srclibs
+fi
+
+################################################################################
+# 
+# Libraries for all models
+#
+
+TARFILE_DIRS=""
+for srclib in $srclibs; do
+ TARFILE_DIRS=${TARFILE_DIRS}" src/lib/${srclib}"
+done
+export TARFILE_DIRS
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Print_par_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Print_par_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Print_par_models.h	(revision 1677)
@@ -0,0 +1,83 @@
+
+export TARGETMODE=${target_mode}
+
+# echo ' '
+if [ "$MAKETARGET" = all ]; then
+  echo 'The model will be updated.' 
+  echo '         Target mode:      '$TARGETMODE
+  echo '         Message passing : '$CHAN
+elif [ "$MAKETARGET" = lib ]; then
+  echo 'The model library will be created; no executable.' 
+  echo '         Target mode:      '$TARGETMODE
+elif [ "$MAKETARGET" = clean ]; then
+  echo 'The model build directory and model libraries will be cleaned.' 
+elif [ "$MAKETARGET" = tar ]; then
+  echo 'A tar-file of the model including all necessary '
+  echo 'libraries will be created.'
+fi
+echo ' '
+
+if [ $CHAN = NONE ]; then
+  export COUPLER=NONE
+fi
+
+export SUBMOD1=""
+export SUBMOD1LIB=""
+
+#
+# Version acronyms must start with "_"
+#
+
+vers_pref=` echo ${model_version} | cut -c1-1 `
+if [ ! "${vers_pref}" = "_" ] && [ ! "${vers_pref}" = "" ]; then
+    echo ERROR: The compile script does not have a valid model version.
+    echo '      A model version acronym must start with an underscore.'
+    echo '      The compilation is stopped!'
+    exit 1
+fi
+
+export MODVERS=${model_version}
+
+#
+# check against list of possible partner models:
+#
+
+for cpl_mod in ${cpl_to}; do
+  cpl_to_ok=not_ok
+  for poss_cpl_mod in ${poss_cpl_mods}; do
+    if [ ${cpl_mod} = ${poss_cpl_mod} ] || [ ${cpl_mod} = ${MODEL_DIR} ];then
+      cpl_to_ok=ok
+    fi
+  done
+  if [ "${cpl_to_ok}" = "not_ok" ]; then
+     echo ERROR: Model ${cpl_mod} specified in the list of partner models
+     echo '       does not appear in the list of possible partner models.'
+     echo '       Check the lists and try again.'
+     echo 'The compilation is stopped.'
+     exit 1
+  fi
+done
+
+echo '***********************************************************************'
+echo '*'
+if [ "${cpl_to}" = "" ] || [ "${cpl_to}" = " " ] || \
+   [ "${cpl_to}" = ${MODEL_DIR} ]; then
+  echo '* The model is prepared for an uncoupled constellation.'
+else
+  echo '* The model is prepared for a coupled model constellation with :'
+  for cpl_mod in ${cpl_to}; do
+    echo '*    '${cpl_mod}
+  done
+fi
+echo '*'
+echo '***********************************************************************'
+
+if [ ! $CHAN = NONE ] && [ ! $MODEL_DIR = "oasis3" ] && [ "${cpl_to}" = " " ]; then
+  echo '***********************************************************************'
+  echo '*'
+  echo '* Message passing MPI1/2 without partner model is not possible!'
+  echo '* The compilation is stopped!'
+  echo '*'
+  echo '***********************************************************************'
+  exit 1
+fi
Index: CPL/oasis3/trunk/util/compile/frames/include/Print_par_oasis3.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Print_par_oasis3.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Print_par_oasis3.h	(revision 1677)
@@ -0,0 +1,5 @@
+
+#
+# Special parameter check for OASIS3
+#
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Prolog_all.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Prolog_all.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Prolog_all.h	(revision 1677)
@@ -0,0 +1,12 @@
+################################# Prolog  #######################################
+#
+# 'Prolog' : Node name and operating system etc.
+#
+
+export NODE=$node
+
+echo ' '
+echo 'This script runs on node ' $NODE'.'
+
+cd $SCRIPTDIR
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Prolog_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Prolog_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Prolog_libs.h	(revision 1677)
@@ -0,0 +1,3 @@
+cd ..
+export SRCROOT=`pwd`
+# echo 'PRISM top source root directory is '$SRCROOT
Index: CPL/oasis3/trunk/util/compile/frames/include/Prolog_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Prolog_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Prolog_models.h	(revision 1677)
@@ -0,0 +1,8 @@
+cd ../../..
+export SRCROOT=`pwd`
+
+export MODHOME=$SCRIPTDIR
+export MODEL_DIR=`basename $MODHOME`
+
+echo ' '
+echo 'Model directory is '$MODHOME
Index: CPL/oasis3/trunk/util/compile/frames/include/Save_exec.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Save_exec.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Save_exec.h	(revision 1677)
@@ -0,0 +1,43 @@
+# 
+#--------------------------------------------------------------------------------
+# Save executable
+# 
+
+if [ "$MAKETARGET" = "all" ]; then
+
+cd $bin
+
+if [ -f ${EXEC}.x ]; then
+  execname=${EXEC}.x
+  if [ ${MODEL_DIR} = "mpi-om"  ]; then
+    if [ $newstart = yes ]; then
+      execname=${EXEC}_newstart.x   
+      mv ${EXEC}.x ${execname}
+      echo '-------------------------------------------------------------'
+      echo ' You created the executable to start from initial conditions.'
+      echo ' To create the executable for the following runs '
+      echo ' edit the compile script COMP_'${MODEL_DIR}'.'${NODE}''
+      echo ' and set newstart=no (instead of newstart=yes)'
+      echo ' then run it again.'
+      echo '------------------------------------------------------------'
+    fi
+  fi
+  echo ' '
+  echo 'Executable : '$bin/$execname
+  if [ ${MODEL_DIR} = "lmdz" ]; then
+    if [ -f ${EXEC}_newstart.x ]; then
+      echo 'Second Executable : '$bin/${EXEC}_newstart.x
+    else
+      echo 'ERROR creating second executable used for newstart'
+    fi
+  fi
+  if [ ${MODEL_DIR} = "oasis3" ]; then
+      cp -p ${EXEC}.x ../../../bin/oasis
+  fi    
+else
+  echo ' '
+  echo 'No executable created.'
+  echo ' '
+fi
+
+fi
Index: CPL/oasis3/trunk/util/compile/frames/include/Status_libs_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Status_libs_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Status_libs_frm.h	(revision 1677)
@@ -0,0 +1,28 @@
+# 
+# Print compilation status
+# 
+
+if [ $MAKETARGET != "tar" ] ; then
+  echo ' '
+  cat $BLDROOT/lib.status
+  set +e
+  grep -v ': 0' $BLDROOT/lib.status
+  if [ $? != 0 ]; then
+    echo 'Libraries ...'
+    echo $srclibs
+    if [ $MAKETARGET = all   ]; then echo '... are up-to-date!' ; fi
+    if [ $MAKETARGET = clean ]; then echo '... are cleaned!'    ; fi
+    echo ' '
+  else
+   if [ $MAKETARGET = all   ]; then  echo 'Updating libraries '$srclibs' failed !'; fi
+   if [ $MAKETARGET = clean ]; then  echo 'Cleaning libraries '$srclibs' failed !'; fi
+    echo 'Compilation is stopped!'
+    exit 1
+  fi
+  set -e
+fi
+echo ' '
+
+#
+################################################################################
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Status_mods_frm.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Status_mods_frm.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Status_mods_frm.h	(revision 1677)
@@ -0,0 +1,26 @@
+# 
+# Print compilation status
+# 
+
+if [ $MAKETARGET != "tar" ] ; then
+  echo ' '
+  cat $BLDROOT/${MODEL_DIR}.status
+  set +e
+  grep -v ': 0' $BLDROOT/${MODEL_DIR}.status
+  if [ $? != 0 ]; then
+    if [ $MAKETARGET = all   ]; then echo ${MODEL_DIR}' ... is up-to-date!' ; fi
+    if [ $MAKETARGET = clean ]; then echo ${MODEL_DIR}' ... is cleaned!' ; fi
+    echo ' '
+  else
+    if [ $MAKETARGET = all   ]; then echo 'Updating '${MODEL_DIR}' failed!' ; fi
+    if [ $MAKETARGET = clean ]; then echo 'Cleaning '${MODEL_DIR}' failed!' ; fi
+    echo 'Compilation of '${MODEL_DIR}' is stopped!'
+    exit 1
+  fi
+  set -e
+fi
+echo ' '
+
+#
+################################################################################
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_all.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_all.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_all.h	(revision 1677)
@@ -0,0 +1,52 @@
+################################################################################
+#
+# Create the top level Makefile
+#
+
+cat > Top_Makefile_$$ <<'EOF1'
+
+export
+
+SHELL = /bin/ksh
+ 
+builddir = ./
+
+prefix = ../../../..
+
+includedir = ${prefix}/include
+
+configdir = ${prefix}/config
+
+exec_prefix = ../../..
+
+top_builddir = $(exec_prefix)/build
+
+bindir = $(exec_prefix)/bin
+
+libdir = $(exec_prefix)/lib
+  
+INCLUDES = -I$(NETCDF_INCLUDE) -I$(MPI_INCLUDE) -I$(SYS_INCLUDE)
+
+F90      = ${F90com}
+f90      = ${f90com}
+F        = ${Fcom}
+f        = ${fcom}
+CC       = $(cc)
+CPP      = ${cc} -E
+AR       = ${ar}
+AS       = ${as}
+
+AFLAGS   = $(AFLAG)
+
+ARFLAGS   = $(ARFLAG)
+
+CCFLAGS  = -I$(configdir) -I$(SYS_INCLUDE) $(CCFLAG) $(CPPFLAGCC)
+
+F90FLAGS = $(F90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+FFLAGS = $(FFLAG) $(INCLUDES) $(CPPFLAGF90)
+
+f90FLAGS = $(f90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+fFLAGS = $(fFLAG) $(INCLUDES) $(CPPFLAGF90)
+
Index: CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_libs.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_libs.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_libs.h	(revision 1677)
@@ -0,0 +1,40 @@
+COUPLE = ${COUPLER}
+
+MPPFLAGS = $(MPPFLAG)
+
+LIBDIRS  = ${BLDLIBS}
+
+all:
+	@for DIR in $(LIBDIRS) ;\
+	  do \
+	    back=`pwd`; \
+	    echo ' ' ; \
+	    cd ../../lib/$$DIR ;\
+	    $(MAKE) -f  Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$DIR ':' $$status >> $(BLDROOT)/lib.status ; \
+	    if [ $$status != 0 ] ; then \
+	      echo "Exit status from make was $$status" ; \
+	    fi ; \
+	    cd $$back ; \
+	  done
+clean:
+	@for DIR in $(LIBDIRS) ;\
+	  do \
+	    back=`pwd`; \
+	    echo ' ' ; \
+	    cd ../../lib/$$DIR ;\
+	    $(MAKE) -f  Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$DIR ':' $$status >> $(BLDROOT)/lib.status ; \
+	    if [ $$status != 0 ] ; then \
+	      echo "Exit status from make was $$status"  ; \
+	    fi ; \
+	    cd $$back ; \
+	  done
+tar:
+	cd $(prefix) ; \
+	tar -cvf ${TARFILE} \
+	${TARFILE_DIRS} \
+	util/compile
+EOF1
+
+#	util/COMP_libs.NodeName  \
Index: CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_models.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_models.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include/Top_makefile_models.h	(revision 1677)
@@ -0,0 +1,42 @@
+top_srcdir = $(prefix)/src/mod/${MODEL_DIR}
+
+LIBS     = $(MODLIBS) $(OTHLIBS) $(NETCDF_LIB) $(MPI_LIB) $(LIB1) $(LIB2) $(LIB3)
+
+LDFLAGS  = $(LDFLAG)
+
+lib: all
+
+all:
+	@for SRCDIR in $(SRCCOMP) ;\
+	  do \
+	    export SRC=$$SRCDIR;\
+	    echo Now updating : $$SRCDIR ...;\
+	    $(MAKE) -f $(top_srcdir)/$$SRCDIR/Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$SRCDIR ':' $$status >> $(BLDROOT)/$(MODEL_DIR).status ; \
+	    if [ $$status != 0 ] ; then \
+	        echo "Exit status from make was $$status"  ; \
+	    fi ; \
+	  done
+
+clean:
+	@for SRCDIR in $(SRCCOMP) ;\
+	  do \
+	    export SRC=$$SRCDIR;\
+	    echo Now cleaning : $$SRCDIR ...;\
+	    $(MAKE) -f $(top_srcdir)/$$SRCDIR/Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$SRCDIR ':' $$status >> $(BLDROOT)/$(MODEL_DIR).status ; \
+	    if [ $$status != 0 ] ; then \
+	        echo "Exit status from cleaning was $$status"  ; \
+	    fi ; \
+	  done
+
+tar:
+	cd $(prefix) ; \
+	tar -cvf $(TARFILE) \
+	src/mod/$(MODEL_DIR)/*/*  \
+	$(TARFILE_DIRS) \
+	util/compile util/running
+
+EOF1
+#	src/mod/$(MODEL_DIR)/COMP_$(MODEL_DIR).NodeName util/COMP_libs.NodeName  \
+
Index: CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_libs_brodie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_libs_brodie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_libs_brodie.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on brodie
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optl=" "
+    optf=" -Wf,-pvctl noassume "
+    optf77=" -Wf,-pvctl noassume "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC"
+    optf77="-eC"
+    optl="-Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt"
+    optf77="-Chopt"
+    optl="-Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
Index: CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_oasis3_brodie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_oasis3_brodie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_brodie/Compile_mode_oasis3_brodie.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on brodie 
+
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC -Wf,-init stack=nan heap=nan"
+    optf77="-eC -Wf,-init stack=nan heap=nan"
+    optl="-Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-p"
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_brodie/OSspecific_brodie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_brodie/OSspecific_brodie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_brodie/OSspecific_brodie.h	(revision 1677)
@@ -0,0 +1,37 @@
+#
+# All models should use cpp flag __SX for activation of platform dependent 
+#     source code on SUPER-SX machines !
+#
+# `uname -n` : brodie (cross compiling only) 
+# `uname -s` : Linux
+# `uname -m` : SX-6
+#
+# With old compiler revision which do not allow for the
+# option   optdbl="-Wf,-A idbl4" use:
+#          optdbl="-Wf,-A  dbl4" AND -D__SXdbl4
+#
+
+#  export CPPFLAG=" -D__SX -D__SX__ "
+  export CPPFLAG="-D__SX"
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="-EP ${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="-EP ${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_brodie/Sitespecific_brodie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_brodie/Sitespecific_brodie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_brodie/Sitespecific_brodie.h	(revision 1677)
@@ -0,0 +1,58 @@
+############### Site and OS dependent specifications ###########################
+#
+#                brodie :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != brodie ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a brodie node (cross compiling for SX)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=SX                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=/SXlocal/pub/netCDF/netCDF-3.6.1
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` /SX/usr/bin/sxf90 -V ` 
+  fi
+
+  export F90com=/SX/usr/bin/sxmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=/SX/usr/bin/sxmpic++
+  export ar=/SX/usr/bin/sxar
+  export as="sxas"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_libs_curie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_libs_curie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_libs_curie.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on titane
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian -xHost"
+    optf77="-convert big_endian -xHost"
+    optl=""
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-xHost"
+    optf77="-xHost"
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf="-xHost"
+    optf77="-xHost"
+    optl="-xHost"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
Index: CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_oasis3_curie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_oasis3_curie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_curie/Compile_mode_oasis3_curie.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on titane 
+
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian -xHost"
+    optf77="-convert big_endian -xHost"
+    optl="-xHost"
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-xHost"
+    optf77="-xHost"
+    optl="-xHost"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-xHost"
+    optf77="-xHost"
+    optl="-xHost"
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf="-xHost"
+    optf77="-xHost"
+    optl="-xHost"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
+
Index: CPL/oasis3/trunk/util/compile/frames/include_curie/OSspecific_curie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_curie/OSspecific_curie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_curie/OSspecific_curie.h	(revision 1677)
@@ -0,0 +1,29 @@
+#
+#
+# `uname -n` : curie 
+# `uname -s` : Linux
+# `uname -m` : x64
+#
+  export CPPFLAG=""
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_curie/Sitespecific_curie.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_curie/Sitespecific_curie.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_curie/Sitespecific_curie.h	(revision 1677)
@@ -0,0 +1,58 @@
+############### Site and OS dependent specifications ###########################
+#
+#                curie :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != curie ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a curie node '
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=X64
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=""
+
+  export NETCDF_LIB="-L${NETCDF_LIB_DIR} -lnetcdff -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDF_INC_DIR}
+
+
+  ##export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` mpif90 -V ` 
+  fi
+
+  export F90com=mpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=cc
+  export ar=ar
+  export as=""
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_libs_mercure.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_libs_mercure.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_libs_mercure.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on mercure
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optl=" -size_t64 "
+    optf=" -Wf,-pvctl noassume "
+    optf77=" -Wf,-pvctl noassume "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC"
+    optf77="-eC"
+    optl="-size_t64 -Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt"
+    optf77="-Chopt"
+    optl="-size_t64 -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
Index: CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_oasis3_mercure.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_oasis3_mercure.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_mercure/Compile_mode_oasis3_mercure.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on mercure 
+
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-size_t64  "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC -Wf,-init stack=nan heap=nan"
+    optf77="-eC -Wf,-init stack=nan heap=nan"
+    optl="-size_t64 -Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" -size_t64 -p"
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-size_t64 -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_mercure/OSspecific_mercure.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_mercure/OSspecific_mercure.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_mercure/OSspecific_mercure.h	(revision 1677)
@@ -0,0 +1,37 @@
+#
+# All models should use cpp flag __SX for activation of platform dependent 
+#     source code on SUPER-SX machines !
+#
+# `uname -n` : mercure (cross compiling only) 
+# `uname -s` : Linux
+# `uname -m` : SX-6
+#
+# With old compiler revision which do not allow for the
+# option   optdbl="-Wf,-A idbl4" use:
+#          optdbl="-Wf,-A  dbl4" AND -D__SXdbl4
+#
+
+#  export CPPFLAG=" -D__SX -D__SX__ "
+  export CPPFLAG="-D__SX"
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="-EP ${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="-EP ${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_mercure/Sitespecific_mercure.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_mercure/Sitespecific_mercure.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_mercure/Sitespecific_mercure.h	(revision 1677)
@@ -0,0 +1,58 @@
+############### Site and OS dependent specifications ###########################
+#
+#                mercure :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != mercure ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a mercure node (cross compiling for SX)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=SX                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=${NETCDF_SX_INCLUDEDIR:-/usr/local/SX8/soft/netcdf/include}/..
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` sxf90 -V ` 
+  fi
+
+  export F90com=sxmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=sxmpic++
+  export ar=sxar
+  export as="sxas"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_libs.moon
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_libs.moon	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_libs.moon	(revision 1677)
@@ -0,0 +1,561 @@
+#! /bin/ksh
+
+
+################################################################################
+#
+#     C O M P I L E  -  script for maintaining PRISM libraries.
+#                                                                       
+#     File       : ~/util/COMP_libs
+#
+#     This script is used to compile or clean any PRISM library.
+#     This include libraries used exclusively in any of the models
+#     or those used by the coupler only, or those shared by the models.
+#     
+#     When needed, different versions of the libraries are created.
+#     At the moment these are MPI1/MPI2 libraries.  
+#     
+#     This script is called directly by the administrator or SMS
+#     or by the model's compile scripts (on scripting level).
+#     When called by the model's compile scripts it checks and updates 
+#     the libraries needed to compile the models and only those.
+#     
+################################################################################
+#
+#     4 positional parameters are possible:
+#		 	        $1=make_target       (optional)
+#				$2=list_of_libraries (optional)
+#    		 	        $3=message_passing   (optional)
+#		 	        $4=calling_model     (optional)
+#
+#     Usage : COMP_libs        ["make_target" ["list_of_libraries" \
+#                              ["message_passing"  \
+#                              ["calling_model"]]]]
+#
+#     If called with no parameters, the defaults given below
+#     are used. If parameter n is specified; the parameter 1,...n-1
+#     must be specified as well.
+#     Note: parameter 4 is not used on the scripting level.
+#
+################################################################################
+
+set -e
+
+################### Start of user specifications (defaults) ####################
+#
+
+# message_passing                       : NONE   /  MPI 2/1
+
+message_passing=MPI1
+
+# coupler                               : oasis3
+# use_key_noIO                          : whether mpp_io will be used for I/O
+# 
+coupler=oasis3
+use_key_noIO=no
+
+# list_of_libraries  : any list of PRISM libraries possible
+# compile mode       : default/opt/..
+
+#compile_mode=default
+compile_mode=debug
+
+use_NetCDF=yes
+
+list_of_libraries=" anaisg anaism clim fscint mpp_io psmile scrip"
+
+# make_target                           : clean/all/tar/lib
+make_target=all
+
+######################## Command line parameter  ###############################
+# 
+# Help function
+#
+if [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '----------- Usage -----------------------------------------------'
+  echo ' $1=make_target       (all/tar/clean; optional)'
+  echo ' $2=list_of_libraries (anaisg/anaism/clim/etc.; optional)'
+  echo ' $3=message_passing   (NONE/MPI1/MPI2; optional)'
+  echo ' '
+  echo ' Default active values are:'
+  echo ' make_target       : '${make_target}
+  echo ' list_of_libraries : '${list_of_libraries}
+  echo ' message_passing   : '${message_passing}
+  echo '-----------------------------------------------------------------'
+  exit 1
+fi
+
+# Overwrite with command line parameter if specified
+
+[ "$1" = "" ] || make_target=$1
+[ "$3" = "" ] || message_passing=$3
+#
+# if no message passing is specified, only compile the interpolation libraries
+#
+
+if [ ${message_passing} = "NONE" ]; then
+  list_of_libraries=" anaisg anaism fscint scrip"
+fi
+
+[ "$2" = "" ] || list_of_libraries=$2
+
+set -u
+
+
+######################## Input checks : all  ########################
+# 
+#
+
+if [ "${make_target}" != "clean" ] && \
+   [ "${make_target}" != "all" ]   && \
+   [ "${make_target}" != "lib" ]   && \
+   [ "${make_target}" != "tar" ];       then 
+  echo " Invalid target : "${make_target}
+  echo " The task is stopped!"
+  exit 1
+fi
+
+if [ "${message_passing}" != "MPI2" ] && \
+   [ "${message_passing}" != "MPI1" ] && \
+   [ "${message_passing}" != "NONE" ];     then 
+  echo " Invalid option for message passing : "${message_passing}
+  echo " The task is stopped!"
+  exit 1
+fi
+
+######################## Input checks : libraries only  ########################
+# 
+
+for library in ${list_of_libraries}; do
+  if [ "${library}" != "anaisg" ]   && \
+     [ "${library}" != "anaism" ]   && \
+     [ "${library}" != "blas" ]     && \
+     [ "${library}" != "clim" ]     && \
+     [ "${library}" != "fscint" ]   && \
+     [ "${library}" != "ioipsl" ]   && \
+     [ "${library}" != "lapack" ]   && \
+     [ "${library}" != "linpack" ]   && \
+     [ "${library}" != "mpp_io" ]   && \
+     [ "${library}" != "netcdf90" ] && \
+     [ "${library}" != "psmile" ]   && \
+     [ "${library}" != "scrip" ]    && \
+     [ "${library}" != "libV4" ]    && \
+     [ "${library}" != "svipc" ]    && \
+     [ "${library}" != "support" ];       then 
+    echo " Invalid library : "${library}
+    echo " The task is stopped!"
+    exit 1
+  fi
+done
+
+
+######################## Set and print input parameter: all  ###################
+# 
+
+export COUPLER=${coupler}
+
+export MAKETARGET=${make_target}
+echo " "
+echo "Make target : "$MAKETARGET
+
+export CHAN=${message_passing}
+
+######################## Set and print input parameters: libs  #################
+# 
+
+export srclibs=${list_of_libraries}
+echo " "
+if [ "$MAKETARGET" = "all" ]; then
+  echo "Libraries which will be updated :" 
+  echo $srclibs
+elif [ "$MAKETARGET" = "clean" ]; then
+  echo "Libraries which will be cleaned :" 
+  echo $srclibs
+elif [ "$MAKETARGET" = "tar" ]; then
+  echo "A tar-file of libraries will be created with:"
+  echo $srclibs
+fi
+
+################################################################################
+# 
+# Libraries for all models
+#
+
+TARFILE_DIRS=""
+for srclib in $srclibs; do
+ TARFILE_DIRS=${TARFILE_DIRS}" src/lib/${srclib}"
+done
+export TARFILE_DIRS
+
+
+
+scriptdir=`dirname $0`
+cd $scriptdir
+export SCRIPTDIR=`pwd`
+node=`uname -n`
+node1_7=`echo ${node} | cut -c1-7`
+if [ ${node1_7} = platine ]; then node=${node1_7}; fi
+
+################################# Prolog  #######################################
+#
+# 'Prolog' : Node name and operating system etc.
+#
+
+export NODE=$node
+
+echo ' '
+echo 'This script runs on node ' $NODE'.'
+
+cd $SCRIPTDIR
+
+cd ..
+export SRCROOT=`pwd`
+# echo 'PRISM top source root directory is '$SRCROOT
+export TARFILE=libs_`date +%y%m%d`.tar
+
+############### Site and OS dependent specifications ###########################
+#
+#                moon :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != moon ]; then
+  if   [ ${NODE} != moon2 ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a moon node (cross compiling for ES)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=ES                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=/S/home010/c0010/ES
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -L/ES/opt/mathkeisan/inst/lib0 -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` esf90 -V ` 
+  fi
+
+  export F90com=esmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=esmpic++
+  export ar=esar
+  export as="esas"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
+# Compile modes (specified by user): libraries on mercure
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optl=" "
+    optf=" -Wf,-pvctl noassume "
+    optf77=" -Wf,-pvctl noassume "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume -ftrace"
+    optf77=" -Wf,-pvctl noassume -ftrace"
+    optl=" -ftrace"
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt"
+    optf77="-Chopt"
+    optl=" -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+#
+# All models should use cpp flag __SX for activation of platform dependent 
+#     source code on SUPER-SX machines !
+#
+# `uname -n` : moon (cross compiling only) 
+# `uname -s` : HP-UX
+# `uname -m` : 
+#
+
+  export CPPFLAG="-D__SX -DSX"
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="-EP ${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="-EP ${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
+
+################################################################################
+#
+# Libraries CPP flags not depending on site or OS
+#
+
+  CPPFLAG=$CPPFLAG" -Duse_comm_${CHAN} -Duse_libMPI"
+
+  if [ ${use_key_noIO} = yes ]; then 
+    CPPFLAG=$CPPFLAG" -Dkey_noIO"
+  fi
+  if [ ${use_NetCDF} = yes ]; then
+    CPPFLAG=$CPPFLAG" -Duse_netCDF"
+  fi
+
+  CPPFLAG=$CPPFLAG" -DNC_DOUBLE"
+
+export CPPFLAGCC=$CPPFLAG
+
+CPPFLAGF90=""
+for flag in $CPPFLAG ; do
+ CPPFLAGF90=$CPPFLAGF90$CPPFLAGSEP$flag
+done
+if [ "$CPPFLAGF90" != "" ]; then 
+  CPPFLAGF90=$CPPFLAGF90start$CPPFLAGF90
+fi
+export CPPFLAGF90
+
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  echo ' '
+  echo "CPP flags used with the cc command: "
+  echo $CPPFLAGCC
+  echo ' '
+  echo "CPP flags used with the f90 command: "
+  echo $CPPFLAGF90
+fi
+
+
+################################# Directories   ################################
+# 
+# Container 'Build the build' : make build directories if needed
+#
+
+libs=${BLDROOT}/lib
+[ -d $libs ] || mkdir -p $libs
+
+lib=${BLDROOT}/build/lib
+
+BLDLIBS=" "
+bldlib=""
+for library in $srclibs; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    bldlib=${library}.${CHAN}
+  else
+    bldlib=${library}
+  fi  
+  if [ ! -d ${lib}/$bldlib  ]; then
+    echo 'Making build directory '${lib}/$bldlib' ...'
+    mkdir -p ${lib}/$bldlib
+  fi
+  ${cp} -p ${SRCROOT}/src/lib/$library/src/Makefile ${lib}/$bldlib
+  BLDLIBS=${BLDLIBS}" "$bldlib
+done
+export BLDLIBS
+
+cd ${lib}/$bldlib
+
+
+################################################################################
+#
+# Create the top level Makefile
+#
+
+cat > Top_Makefile_$$ <<'EOF1'
+
+export
+
+SHELL = /bin/ksh
+ 
+builddir = ./
+
+prefix = ../../../..
+
+includedir = ${prefix}/include
+
+configdir = ${prefix}/config
+
+exec_prefix = ../../..
+
+top_builddir = $(exec_prefix)/build
+
+bindir = $(exec_prefix)/bin
+
+libdir = $(exec_prefix)/lib
+  
+INCLUDES = -I$(NETCDF_INCLUDE) -I$(MPI_INCLUDE) -I$(SYS_INCLUDE)
+
+F90      = ${F90com}
+f90      = ${f90com}
+F        = ${Fcom}
+f        = ${fcom}
+CC       = $(cc)
+CPP      = ${cc} -E
+AR       = ${ar}
+AS       = ${as}
+
+AFLAGS   = $(AFLAG)
+
+ARFLAGS   = $(ARFLAG)
+
+CCFLAGS  = -I$(configdir) -I$(SYS_INCLUDE) $(CCFLAG) $(CPPFLAGCC)
+
+F90FLAGS = $(F90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+FFLAGS = $(FFLAG) $(INCLUDES) $(CPPFLAGF90)
+
+f90FLAGS = $(f90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+fFLAGS = $(fFLAG) $(INCLUDES) $(CPPFLAGF90)
+
+COUPLE = ${COUPLER}
+
+MPPFLAGS = $(MPPFLAG)
+
+LIBDIRS  = ${BLDLIBS}
+
+all:
+	@for DIR in $(LIBDIRS) ;\
+	  do \
+	    back=`pwd`; \
+	    echo ' ' ; \
+	    cd ../../lib/$$DIR ;\
+	    $(MAKE) -f  Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$DIR ':' $$status >> $(BLDROOT)/lib.status ; \
+	    if [ $$status != 0 ] ; then \
+	      echo "Exit status from make was $$status" ; \
+	    fi ; \
+	    cd $$back ; \
+	  done
+clean:
+	@for DIR in $(LIBDIRS) ;\
+	  do \
+	    back=`pwd`; \
+	    echo ' ' ; \
+	    cd ../../lib/$$DIR ;\
+	    $(MAKE) -f  Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$DIR ':' $$status >> $(BLDROOT)/lib.status ; \
+	    if [ $$status != 0 ] ; then \
+	      echo "Exit status from make was $$status"  ; \
+	    fi ; \
+	    cd $$back ; \
+	  done
+tar:
+	cd $(prefix) ; \
+	tar -cvf ${TARFILE} \
+	${TARFILE_DIRS} \
+	util/compile
+EOF1
+
+#	util/COMP_libs.moon  \
+
+stdout=$SCRIPTDIR/COMP_libs.log
+stderr=$SCRIPTDIR/COMP_libs.err
+
+if [ -f $BLDROOT/lib.status ]; then rm $BLDROOT/lib.status; fi
+
+################################################################################
+#
+# Execute makefile  :   -p : listing of all default rules
+#                       -d : debug
+#                       -k : dont stop when error occurs
+# 
+
+mv Top_Makefile_$$ ../Top_Makefile_$$
+
+if [ -f ${stdout} ] ; then
+   rm -f ${stdout}
+fi
+if [ -f ${stderr} ] ; then
+   rm -f ${stderr}
+fi
+
+make -f ../Top_Makefile_$$ $MAKETARGET -k
+
+rm ../Top_Makefile_$$
+
+# 
+# Print compilation status
+# 
+
+if [ $MAKETARGET != "tar" ] ; then
+  echo ' '
+  cat $BLDROOT/lib.status
+  set +e
+  grep -v ': 0' $BLDROOT/lib.status
+  if [ $? != 0 ]; then
+    echo 'Libraries ...'
+    echo $srclibs
+    if [ $MAKETARGET = all   ]; then echo '... are up-to-date!' ; fi
+    if [ $MAKETARGET = clean ]; then echo '... are cleaned!'    ; fi
+    echo ' '
+  else
+   if [ $MAKETARGET = all   ]; then  echo 'Updating libraries '$srclibs' failed !'; fi
+   if [ $MAKETARGET = clean ]; then  echo 'Cleaning libraries '$srclibs' failed !'; fi
+    echo 'Compilation is stopped!'
+    exit 1
+  fi
+  set -e
+fi
+echo ' '
+
+#
+################################################################################
+
+
+
+exit
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_oasis3_MPI1.moon
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_oasis3_MPI1.moon	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/COMP_oasis3_MPI1.moon	(revision 1677)
@@ -0,0 +1,843 @@
+#! /bin/ksh
+
+
+#########################################################################
+#
+#     C O M P I L E  -  script for component model 'oasis3'.
+#                                                                       
+#     File       : ~/src/mod/oasis3/COMP_oasis3
+#
+#     2 positional parameters are possible:
+#	                        $1=Make target       (optional:all,lib,clean,tar)
+#    		 	        $2=message_passing   (optional)
+#
+#     message_passing "NONE" will cause the script NOT to update and load the 
+#     psmile/mpp_io libraries. It should therefore be used for creation of
+#     executables w/o submodels which do not communicate through OASIS3.
+#     For communication through OASIS3 use "MPI1" or "MPI2".
+#
+#     If called with $1=clean, only the model's build directory
+#     is cleaned, not the libraries.
+#
+#     If called with $1=lib, only the model's library (archive with .o files)
+#     is updated.
+#
+#     If called with $1=tar, a tar file with the source code of the model 
+#     and all libraries it links to is created. The tar file is moved to 
+#     PRISM source-root directory. 
+#
+#     If called with $1=all, this script checks all libraries needed by 
+#     the model. If these are not up-to-date they will be made by calling  
+#     the library-compile script with "all" for the target
+#                                with       the models libraries,
+#                                with       the message passing used by the model,
+#                                with       the model name
+#     as positional parameters to that script.
+#     If the libraries are ok the model will be made.
+#     
+#     The list of models being part of the coupled constellation (cpl_to) 
+#     is used to set the right cpp flags if needed. It is checked against
+#     a list of models that may be specified.
+#     For a standalone model specify " " (blank).
+#     For main models: 
+#     If the list of models being part of the coupled constellation (cpl_to)
+#     contains the name of a valid submodel the library with the source
+#     code of that submodel is created first.
+#
+#     Cleaning of libraries is not possible with this script.
+#
+#     Usage : COMP_oasis3 \
+#                        ["make_target"  ["message_passing" ] ]
+#
+#     If called with no parameters, the defaults given below
+#     are used. If parameter n is specified; the parameter 1,...n-1
+#     must be specified as well.
+#
+#########################################################################
+
+
+scriptdir=`dirname $0`
+cd $scriptdir
+export SCRIPTDIR=`pwd`
+node=`uname -n`
+node1_7=`echo ${node} | cut -c1-7`
+if [ ${node1_7} = platine ]; then node=${node1_7}; fi
+
+################################# Prolog  #######################################
+#
+# 'Prolog' : Node name and operating system etc.
+#
+
+export NODE=$node
+
+echo ' '
+echo 'This script runs on node ' $NODE'.'
+
+cd $SCRIPTDIR
+
+cd ../../..
+export SRCROOT=`pwd`
+
+export MODHOME=$SCRIPTDIR
+export MODEL_DIR=`basename $MODHOME`
+
+echo ' '
+echo 'Model directory is '$MODHOME
+export TARFILE=${MODEL_DIR}_`date +%y%m%d`.tar
+
+
+set -e
+
+################### Start of user specifications (defaults) ####################
+#
+
+# message_passing                       : NONE   /  MPI 2/1
+
+message_passing=MPI1
+
+# coupler                               : oasis3
+# use_key_noIO                          : whether mpp_io will be used for I/O
+# 
+coupler=oasis3
+use_key_noIO=no
+
+
+
+# Gui input for all models
+
+target_mode=forced                       : "" / forced
+target_mode=""
+
+cpl_to=" "
+
+
+
+# OASIS3 specific GUI input:
+
+#compile_mode=default
+compile_mode=debug
+
+model_version=""
+
+# make_target                           : clean/all/tar/lib
+make_target=all
+
+submodel_1=""
+
+#
+################### End of user specifications (defaults) ####################
+
+poss_cpl_mods=" "
+
+
+######################## Command line parameter  ###############################
+# 
+# Help function
+#
+if [ "$1" = "--" ] || [ "$1" = "help" ] || [ "$1" = "--help" ] ; then
+  echo 
+  echo '----------- Usage -----------------------------------------------'
+  echo ' $1=make_target       (all/lib/tar/clean; optional)'
+  echo ' $2=message_passing   (MPI1/MPI2; optional)'
+  echo ' '
+  echo ' Default active values are:'
+  echo ' make_target               : '${make_target}
+  echo ' message_passing           : '${message_passing}
+  echo ' '
+  echo '-----------------------------------------------------------------'
+  exit 1
+fi
+
+# Overwrite with command line parameter if specified
+
+[ "$1" = "" ] || make_target=$1
+[ "$2" = "" ] || message_passing=$2
+
+set -u
+
+######################## Input checks : all  ########################
+# 
+#
+
+if [ "${make_target}" != "clean" ] && \
+   [ "${make_target}" != "all" ]   && \
+   [ "${make_target}" != "lib" ]   && \
+   [ "${make_target}" != "tar" ];       then 
+  echo " Invalid target : "${make_target}
+  echo " The task is stopped!"
+  exit 1
+fi
+
+if [ "${message_passing}" != "MPI2" ] && \
+   [ "${message_passing}" != "MPI1" ] && \
+   [ "${message_passing}" != "NONE" ];     then 
+  echo " Invalid option for message passing : "${message_passing}
+  echo " The task is stopped!"
+  exit 1
+fi
+
+
+######################## Set and print input parameter: all  ###################
+# 
+
+export COUPLER=${coupler}
+
+export MAKETARGET=${make_target}
+echo " "
+echo "Make target : "$MAKETARGET
+
+export CHAN=${message_passing}
+
+
+export TARGETMODE=${target_mode}
+
+# echo ' '
+if [ "$MAKETARGET" = all ]; then
+  echo 'The model will be updated.' 
+  echo '         Target mode:      '$TARGETMODE
+  echo '         Message passing : '$CHAN
+elif [ "$MAKETARGET" = lib ]; then
+  echo 'The model library will be created; no executable.' 
+  echo '         Target mode:      '$TARGETMODE
+elif [ "$MAKETARGET" = clean ]; then
+  echo 'The model build directory and model libraries will be cleaned.' 
+elif [ "$MAKETARGET" = tar ]; then
+  echo 'A tar-file of the model including all necessary '
+  echo 'libraries will be created.'
+fi
+echo ' '
+
+if [ $CHAN = NONE ]; then
+  export COUPLER=NONE
+fi
+
+export SUBMOD1=""
+export SUBMOD1LIB=""
+
+#
+# Version acronyms must start with "_"
+#
+
+vers_pref=` echo ${model_version} | cut -c1-1 `
+if [ ! "${vers_pref}" = "_" ] && [ ! "${vers_pref}" = "" ]; then
+    echo ERROR: The compile script does not have a valid model version.
+    echo '      A model version acronym must start with an underscore.'
+    echo '      The compilation is stopped!'
+    exit 1
+fi
+
+export MODVERS=${model_version}
+
+#
+# check against list of possible partner models:
+#
+
+for cpl_mod in ${cpl_to}; do
+  cpl_to_ok=not_ok
+  for poss_cpl_mod in ${poss_cpl_mods}; do
+    if [ ${cpl_mod} = ${poss_cpl_mod} ] || [ ${cpl_mod} = ${MODEL_DIR} ];then
+      cpl_to_ok=ok
+    fi
+  done
+  if [ "${cpl_to_ok}" = "not_ok" ]; then
+     echo ERROR: Model ${cpl_mod} specified in the list of partner models
+     echo '       does not appear in the list of possible partner models.'
+     echo '       Check the lists and try again.'
+     echo 'The compilation is stopped.'
+     exit 1
+  fi
+done
+
+echo '***********************************************************************'
+echo '*'
+if [ "${cpl_to}" = "" ] || [ "${cpl_to}" = " " ] || \
+   [ "${cpl_to}" = ${MODEL_DIR} ]; then
+  echo '* The model is prepared for an uncoupled constellation.'
+else
+  echo '* The model is prepared for a coupled model constellation with :'
+  for cpl_mod in ${cpl_to}; do
+    echo '*    '${cpl_mod}
+  done
+fi
+echo '*'
+echo '***********************************************************************'
+
+if [ ! $CHAN = NONE ] && [ ! $MODEL_DIR = "oasis3" ] && [ "${cpl_to}" = " " ]; then
+  echo '***********************************************************************'
+  echo '*'
+  echo '* Message passing MPI1/2 without partner model is not possible!'
+  echo '* The compilation is stopped!'
+  echo '*'
+  echo '***********************************************************************'
+  exit 1
+fi
+
+#
+# Special parameter check for OASIS3
+#
+
+
+############### Site and OS dependent specifications ###########################
+#
+#                moon :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != moon ]; then
+  if   [ ${NODE} != moon2 ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a moon node (cross compiling for ES)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=ES                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=/S/home010/c0010/ES
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -L/ES/opt/mathkeisan/inst/lib0 -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` esf90 -V ` 
+  fi
+
+  export F90com=esmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=esmpic++
+  export ar=esar
+  export as="esas"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
+# Compile modes (specified by user) : oasis3 on mercure 
+
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 -ftrace"
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 -ftrace"
+    optl=" -ftrace"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-p"
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+
+#
+# All models should use cpp flag __SX for activation of platform dependent 
+#     source code on SUPER-SX machines !
+#
+# `uname -n` : moon (cross compiling only) 
+# `uname -s` : HP-UX
+# `uname -m` : 
+#
+
+  export CPPFLAG="-D__SX -DSX"
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="-EP ${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="-EP ${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
+
+################################################################################
+# 
+# OASIS3 CPP flags not depending on site or OS
+#
+
+CPPFLAG=${CPPFLAG}" -Duse_comm_${CHAN}"
+
+export CPPFLAGCC=$CPPFLAG
+
+CPPFLAGF90=""
+for flag in $CPPFLAG ; do
+ CPPFLAGF90=$CPPFLAGF90$CPPFLAGSEP$flag
+done
+if [ "$CPPFLAGF90" != "" ]; then 
+  CPPFLAGF90=$CPPFLAGF90start$CPPFLAGF90
+fi
+export CPPFLAGF90
+
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  echo ' '
+  echo "CPP flags used with the cc command: "
+  echo $CPPFLAGCC
+  echo ' '
+  echo "CPP flags used with the f90 command: "
+  echo $CPPFLAGF90
+fi
+
+
+#
+#--------------------------------------------------------------------------------
+# Model executable name.
+#
+
+export EXEC=${MODEL_DIR}
+if [ "${SUBMOD1}" != ""  ]; then
+  EXEC=${EXEC}_${SUBMOD1}
+fi
+EXEC=${EXEC}${MODVERS}
+if [ "${CHAN}" != "NONE"  ]; then
+  export EXEC=${EXEC}.${CHAN}
+fi
+
+
+################################################################################
+# 
+# Libraries for oasis3
+#
+
+export SRCCOMP="src"
+
+export MODLIB=$EXEC
+
+srclibs="anaisg anaism scrip fscint psmile mpp_io"
+if [ "$CHAN" != "NONE" ]; then
+  srclibs=${srclibs}" clim"
+fi
+
+export MAINPRG=couple
+#   SRCCOMP : model-src  directories in order they will be compiled      
+#   MODLIB : model  library/ies (should be one only)
+#   srclibs : other PRISM libraries ( $SRCROOT/src/lib...); must be " " if empty
+################################################################################
+# 
+# Libraries needed by all models
+#
+
+if [ "$MAKETARGET" = "all" ]; then
+if [ "$CHAN" != "NONE" ] && [ "${MODEL_DIR}" != "oasis3" ]; then 
+  srclibs=${srclibs}" psmile "
+  if [ $use_key_noIO != yes ]; then 
+    srclibs=${srclibs}" mpp_io"
+  fi
+fi
+fi
+
+################################################################################
+# 
+# Directories for tar file
+#
+
+TARFILE_DIRS=""
+for srclib in $srclibs; do
+ TARFILE_DIRS=${TARFILE_DIRS}" src/lib/${srclib}"
+done
+TARFILE_DIRS=${TARFILE_DIRS}" src/lib/psmile src/lib/mpp_io "
+if [ "${SUBMOD1}" != ""  ]; then
+  TARFILE_DIRS=${TARFILE_DIRS}" src/mod/${SUBMOD1}"
+fi
+export TARFILE_DIRS
+
+################################# Directories   ################################
+# 
+# Make the 'build' directories if needed
+#
+
+echo " "
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  echo The model $MODEL_DIR will be updated
+  if [ "${srclibs}" != " " ]; then
+    echo together with its libraries
+    echo $srclibs '.'
+  else 
+    echo No libraries need to be updated.
+  fi
+fi
+
+if [ ! -d ${BLDROOT}/lib/$MODEL_DIR ]; then
+  echo ' '
+  echo 'Making model library build directory '${BLDROOT}/lib/$MODEL_DIR
+  mkdir -p ${BLDROOT}/lib/$MODEL_DIR
+fi
+
+export MODBUILD=${BLDROOT}/build/mod/${MODEL_DIR}${MODVERS}
+if [ ${CHAN} != "NONE" ]; then
+  MODBUILD=${MODBUILD}.${CHAN}
+fi
+if [ ! -d $MODBUILD ]; then
+  echo ' '
+  echo 'Making build directory '$MODBUILD 
+  mkdir -p $MODBUILD 
+fi
+
+export bin=${BLDROOT}/bin
+[ -d $bin ] || mkdir -p $bin
+
+export OTHLIBS=" "
+if [ "$srclibs" != " "  ]; then
+for library in $srclibs ; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    ldlib=${library}.${CHAN}
+  else
+    ldlib=${library}
+  fi  
+  OTHLIBS=${OTHLIBS}" -l"$ldlib
+done
+OTHLIBS="-L${BLDROOT}/lib ${OTHLIBS}"
+fi
+
+export MODLIBS=" "
+for library in $MODLIB ; do
+  MODLIBS=${MODLIBS}" -l"${library}
+done
+MODLIBS="-L${BLDROOT}/lib/${MODEL_DIR} ${MODLIBS}"
+
+if [ "${SUBMOD1}" != ""  ]; then
+  MODLIBS=${MODLIBS}" -L${BLDROOT}/lib/${SUBMOD1} -l${SUBMOD1LIB}"
+  SUBMOD1LIB=lib${SUBMOD1LIB}.a
+fi
+
+#
+# Dont put paths here; they are included in VPATH
+#
+export DEPLIBS=" "
+for library in $MODLIB $srclibs ; do
+  if [ $library = psmile ] || \
+     [ $library = clim   ]       ; then 
+    ldlib=${library}.${CHAN}
+  else
+    ldlib=${library}
+  fi  
+  DEPLIBS=${DEPLIBS}" lib"${ldlib}.a
+done
+
+cd $MODBUILD
+if [ "$MAKETARGET" != "tar" ]; then
+  echo ' '
+  echo 'Build directory is '$MODBUILD
+fi
+
+#
+# Update external libraries
+#
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+  if [ "$srclibs" != " " ]; then 
+    echo ' '
+    echo 'Checking the libraries ...'
+    if [ ! -f  $SRCROOT/util/COMP_libs.${NODE} ]; then
+      echo --- $SRCROOT/util/COMP_libs.${NODE} must be created first! ---
+      echo --- Use $SRCROOT/util/compile/frames/Create_COMP_libs.frm. ---
+      echo --- This script is stopped!
+      exit 1
+    fi
+    COMP_libs.${NODE} "all" "${srclibs}" "${CHAN}" "${MODEL_DIR}"
+    echo 'Checking the libraries finished '
+    echo ' '
+    echo ' '
+    echo 'Library update exit status : '
+    cat $BLDROOT/lib.status
+    set +e
+    grep -v ': 0' $BLDROOT/lib.status
+    if [ $? != 0 ]; then
+      echo 'Libraries OK'
+      echo ' '
+    else
+      echo "ERROR in $SRCROOT/util : Libraries not updated!"
+      echo "Check the log file for details!"
+      echo ' '
+      exit 1
+    fi
+    rm $BLDROOT/lib.status
+    set -e
+  fi
+fi
+
+#
+# Update submodel
+#
+if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "clean" ]; then 
+  if [ "${SUBMOD1}" != ""  ]; then 
+    echo ' '
+    echo 'Checking the submodel '${SUBMOD1}
+    COMP_submodel=$SRCROOT/src/mod/${SUBMOD1}/COMP_${SUBMOD1}${MODVERS}.${NODE}
+    if [ ! -f ${COMP_submodel} ]; then
+      echo --- ${COMP_submodel} must be created first! ---
+      echo --- Use $SRCROOT/util/compile/frames/Create_COMP_models.frm. ---
+      echo --- This script is stopped!
+      exit 1
+    fi
+    cpl_to=${cpl_to}" "${MODEL_DIR}
+    ${COMP_submodel} "${MAKETARGET}" "${CHAN}"
+    echo 'Checking the submodel finished '
+    echo ' '
+    echo 'Submodel update exit status : '
+    cat $BLDROOT/${SUBMOD1}.status
+    set +e
+    grep -v ': 0' $BLDROOT/${SUBMOD1}.status
+    if [ $? != 0 ]; then
+      echo 'Submodel '${SUBMOD1}' OK'
+      echo ' '
+    else
+      echo "ERROR in $SRCROOT/src/mod/${SUBMOD1} : Submodel not updated!"
+      echo "Check the log file for details!"
+      echo ' '
+      exit 1
+    fi
+    rm $BLDROOT/${SUBMOD1}.status
+    set -e
+  fi  
+fi
+
+
+################################################################################
+#
+# Create the top level Makefile
+#
+
+cat > Top_Makefile_$$ <<'EOF1'
+
+export
+
+SHELL = /bin/ksh
+ 
+builddir = ./
+
+prefix = ../../../..
+
+includedir = ${prefix}/include
+
+configdir = ${prefix}/config
+
+exec_prefix = ../../..
+
+top_builddir = $(exec_prefix)/build
+
+bindir = $(exec_prefix)/bin
+
+libdir = $(exec_prefix)/lib
+  
+INCLUDES = -I$(NETCDF_INCLUDE) -I$(MPI_INCLUDE) -I$(SYS_INCLUDE)
+
+F90      = ${F90com}
+f90      = ${f90com}
+F        = ${Fcom}
+f        = ${fcom}
+CC       = $(cc)
+CPP      = ${cc} -E
+AR       = ${ar}
+AS       = ${as}
+
+AFLAGS   = $(AFLAG)
+
+ARFLAGS   = $(ARFLAG)
+
+CCFLAGS  = -I$(configdir) -I$(SYS_INCLUDE) $(CCFLAG) $(CPPFLAGCC)
+
+F90FLAGS = $(F90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+FFLAGS = $(FFLAG) $(INCLUDES) $(CPPFLAGF90)
+
+f90FLAGS = $(f90FLAG) $(INCLUDES) $(CPPFLAGF90)
+
+fFLAGS = $(fFLAG) $(INCLUDES) $(CPPFLAGF90)
+
+top_srcdir = $(prefix)/src/mod/${MODEL_DIR}
+
+LIBS     = $(MODLIBS) $(OTHLIBS) $(NETCDF_LIB) $(MPI_LIB) $(LIB1) $(LIB2) $(LIB3)
+
+LDFLAGS  = $(LDFLAG)
+
+lib: all
+
+all:
+	@for SRCDIR in $(SRCCOMP) ;\
+	  do \
+	    export SRC=$$SRCDIR;\
+	    echo Now updating : $$SRCDIR ...;\
+	    $(MAKE) -f $(top_srcdir)/$$SRCDIR/Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$SRCDIR ':' $$status >> $(BLDROOT)/$(MODEL_DIR).status ; \
+	    if [ $$status != 0 ] ; then \
+	        echo "Exit status from make was $$status"  ; \
+	    fi ; \
+	  done
+
+clean:
+	@for SRCDIR in $(SRCCOMP) ;\
+	  do \
+	    export SRC=$$SRCDIR;\
+	    echo Now cleaning : $$SRCDIR ...;\
+	    $(MAKE) -f $(top_srcdir)/$$SRCDIR/Makefile $(MAKETARGET); status=$$? ; \
+	    echo $$SRCDIR ':' $$status >> $(BLDROOT)/$(MODEL_DIR).status ; \
+	    if [ $$status != 0 ] ; then \
+	        echo "Exit status from cleaning was $$status"  ; \
+	    fi ; \
+	  done
+
+tar:
+	cd $(prefix) ; \
+	tar -cvf $(TARFILE) \
+	src/mod/$(MODEL_DIR)/*/*  \
+	$(TARFILE_DIRS) \
+	util/compile util/running
+
+EOF1
+#	src/mod/$(MODEL_DIR)/COMP_$(MODEL_DIR).moon util/COMP_libs.moon  \
+
+
+stdout=$SCRIPTDIR/COMP_${MODEL_DIR}.log
+stderr=$SCRIPTDIR/COMP_${MODEL_DIR}.err
+
+if [ -f $BLDROOT/oasis3.status ]; then rm $BLDROOT/oasis3.status; fi
+
+################################################################################
+#
+# Execute makefile  :   -p : listing of all default rules
+#                       -d : debug
+#                       -k : dont stop when error occurs
+# 
+
+if [ -f ${stdout} ] ; then
+   rm -f ${stdout}
+fi
+if [ -f ${stderr} ] ; then
+   rm -f ${stderr}
+fi
+
+make -f Top_Makefile_$$ $MAKETARGET -k
+  
+if [ ! "$MAKETARGET" = "clean" ]; then
+  rm Top_Makefile_$$
+fi
+
+
+# 
+# Print compilation status
+# 
+
+if [ $MAKETARGET != "tar" ] ; then
+  echo ' '
+  cat $BLDROOT/${MODEL_DIR}.status
+  set +e
+  grep -v ': 0' $BLDROOT/${MODEL_DIR}.status
+  if [ $? != 0 ]; then
+    if [ $MAKETARGET = all   ]; then echo ${MODEL_DIR}' ... is up-to-date!' ; fi
+    if [ $MAKETARGET = clean ]; then echo ${MODEL_DIR}' ... is cleaned!' ; fi
+    echo ' '
+  else
+    if [ $MAKETARGET = all   ]; then echo 'Updating '${MODEL_DIR}' failed!' ; fi
+    if [ $MAKETARGET = clean ]; then echo 'Cleaning '${MODEL_DIR}' failed!' ; fi
+    echo 'Compilation of '${MODEL_DIR}' is stopped!'
+    exit 1
+  fi
+  set -e
+fi
+echo ' '
+
+#
+################################################################################
+
+
+# 
+#--------------------------------------------------------------------------------
+# Save executable
+# 
+
+if [ "$MAKETARGET" = "all" ]; then
+
+cd $bin
+
+if [ -f ${EXEC}.x ]; then
+  execname=${EXEC}.x
+  if [ ${MODEL_DIR} = "mpi-om"  ]; then
+    if [ $newstart = yes ]; then
+      execname=${EXEC}_newstart.x   
+      mv ${EXEC}.x ${execname}
+      echo '-------------------------------------------------------------'
+      echo ' You created the executable to start from initial conditions.'
+      echo ' To create the executable for the following runs '
+      echo ' edit the compile script COMP_'${MODEL_DIR}'.'${NODE}''
+      echo ' and set newstart=no (instead of newstart=yes)'
+      echo ' then run it again.'
+      echo '------------------------------------------------------------'
+    fi
+  fi
+  echo ' '
+  echo 'Executable : '$bin/$execname
+  if [ ${MODEL_DIR} = "lmdz" ]; then
+    if [ -f ${EXEC}_newstart.x ]; then
+      echo 'Second Executable : '$bin/${EXEC}_newstart.x
+    else
+      echo 'ERROR creating second executable used for newstart'
+    fi
+  fi
+  if [ ${MODEL_DIR} = "oasis3" ]; then
+      cp -p ${EXEC}.x ../../../bin/oasis
+  fi    
+else
+  echo ' '
+  echo 'No executable created.'
+  echo ' '
+fi
+
+fi
+
+exit
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_libs_moon.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_libs_moon.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_libs_moon.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on mercure
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optl=" "
+    optf=" -Wf,-pvctl noassume "
+    optf77=" -Wf,-pvctl noassume "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume  -ftrace"
+    optf77=" -Wf,-pvctl noassume -ftrace"
+    optl=" -ftrace"
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt"
+    optf77="-Chopt"
+    optl=" -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_oasis3_moon.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_oasis3_moon.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/Compile_mode_oasis3_moon.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on mercure 
+
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 -ftrace"
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 -ftrace"
+    optl=" -ftrace"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-p"
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" -Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/OSspecific_moon.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/OSspecific_moon.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/OSspecific_moon.h	(revision 1677)
@@ -0,0 +1,32 @@
+#
+# All models should use cpp flag __SX for activation of platform dependent 
+#     source code on SUPER-SX machines !
+#
+# `uname -n` : moon (cross compiling only) 
+# `uname -s` : HP-UX
+# `uname -m` : 
+#
+
+  export CPPFLAG="-D__SX -DSX"
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="-EP ${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="-EP ${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_moon/Sitespecific_moon.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_moon/Sitespecific_moon.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_moon/Sitespecific_moon.h	(revision 1677)
@@ -0,0 +1,60 @@
+############### Site and OS dependent specifications ###########################
+#
+#                moon :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != moon ]; then
+  if   [ ${NODE} != moon2 ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a moon node (cross compiling for ES)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=ES                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=/S/home010/c0010/ES
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -L/ES/opt/mathkeisan/inst/lib0 -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` esf90 -V ` 
+  fi
+
+  export F90com=esmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=esmpic++
+  export ar=esar
+  export as="esas"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_libs_platine.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_libs_platine.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_libs_platine.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on platine
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian"
+    optf77="-convert big_endian"
+    optl=""
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
Index: CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_oasis3_platine.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_oasis3_platine.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_platine/Compile_mode_oasis3_platine.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on platine 
+
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian"
+    optf77="-convert big_endian"
+    optl=""
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
+
Index: CPL/oasis3/trunk/util/compile/frames/include_platine/OSspecific_platine.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_platine/OSspecific_platine.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_platine/OSspecific_platine.h	(revision 1677)
@@ -0,0 +1,29 @@
+#
+#
+# `uname -n` : platine 
+# `uname -s` : Linux
+# `uname -m` : ia64
+#
+  export CPPFLAG=""
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_platine/Sitespecific_platine.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_platine/Sitespecific_platine.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_platine/Sitespecific_platine.h	(revision 1677)
@@ -0,0 +1,58 @@
+############### Site and OS dependent specifications ###########################
+#
+#                platine :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != platine ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a platine node '
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=IA64                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=""
+
+  export NETCDFROOT=/usr
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdff -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` mpif90 -V ` 
+  fi
+
+  export F90com=mpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=cc
+  export ar=ar
+  export as=""
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_libs_rhodes.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_libs_rhodes.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_libs_rhodes.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on rhodes 
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optl=" "
+    optf=" -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -Wf,-pvctl noassume loopcnt=5000000 "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC -Wf,-init stack=nan heap=nan"
+    optf77="-eC -Wf,-init stack=nan heap=nan"
+    optl="-Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt"
+    optf77="-Chopt"
+    optl="-Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
Index: CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_oasis3_rhodes.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_oasis3_rhodes.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_rhodes/Compile_mode_oasis3_rhodes.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on rhodes 
+
+  if [ $compile_mode = default ];   then
+    optc=" "
+    optf=" -C vsafe -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77=" -C vsafe -Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" "
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf="-eC -Wf,-init stack=nan heap=nan"
+    optf77="-eC -Wf,-init stack=nan heap=nan"
+    optl="-Wl,-Z 1000000 -Wf,-init stack=nan heap=nan"
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf="-Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Wf,-pvctl noassume loopcnt=5000000 "
+    optl=" -p"
+  elif [ $compile_mode = opt ];     then
+    optc="-Chopt"
+    optf="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optf77="-Chopt -Wf,-pvctl noassume loopcnt=5000000 "
+    optl="-Wl,-Z 1000000 -pi line=1000"
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-dw -Wf,-A idbl4"
+  optnh=""
+  lstflags="-Wf,-L fmtlist transform"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_rhodes/OSspecific_rhodes.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_rhodes/OSspecific_rhodes.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_rhodes/OSspecific_rhodes.h	(revision 1677)
@@ -0,0 +1,36 @@
+#
+# All models should use cpp flag  __SX for activation of 
+# platform dependent source code on SUPER-SX machines !
+#
+# `uname -n` : rhodes (cross compiling only) 
+# `uname -s` : SUPER-UX
+# `uname -m` : SX-5
+#
+# With old compiler revision which do not allow for the
+# option   optdbl="-Wf,-A idbl4" use:
+#          optdbl="-Wf,-A  dbl4" AND -D__SXdbl4
+#
+
+  export CPPFLAG="-D__SX "
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="${optf} -EP ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="${optf77} -EP ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="-Pstack ${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_rhodes/Sitespecific_rhodes.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_rhodes/Sitespecific_rhodes.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_rhodes/Sitespecific_rhodes.h	(revision 1677)
@@ -0,0 +1,60 @@
+############### Site and OS dependent specifications ###########################
+#
+#                rhodes :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != rhodes ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a rhodes node (cross compiling for SX)'
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=SX                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=./
+
+  export NETCDFROOT=/SX/usr/local
+  export NETCDF_LIB="-L${NETCDFROOT}/lib/new -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include/new/netcdf
+
+  export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` /usr/local/bin/sxf90 -V ` 
+  fi
+
+  export F90com=/usr/local/bin/sxmpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=/usr/local/bin/sxmpic++
+  export ar=/usr/local/bin/sxar
+  export as="sxas"
+  export cp=cp
+
+  export cpp=sxcpp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_libs_titane.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_libs_titane.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_libs_titane.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on titane
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian"
+    optf77="-convert big_endian"
+    optl=""
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
Index: CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_oasis3_titane.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_oasis3_titane.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_titane/Compile_mode_oasis3_titane.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on titane 
+
+  if [ $compile_mode = default ];   then
+    optc=" " 
+    optf="-convert big_endian"
+    optf77="-convert big_endian"
+    optl=""
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-i4 -r8"
+  optnh=""
+  lstflags=""
+
Index: CPL/oasis3/trunk/util/compile/frames/include_titane/OSspecific_titane.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_titane/OSspecific_titane.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_titane/OSspecific_titane.h	(revision 1677)
@@ -0,0 +1,29 @@
+#
+#
+# `uname -n` : titane 
+# `uname -s` : Linux
+# `uname -m` : x64
+#
+  export CPPFLAG=""
+
+  export CPPFLAGF90start=" "
+  export CPPFLAGSEP=" "
+
+  export F90FLAG="${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG="${optf77} ${optdbl} ${optnh} ${lstflags}"
+  export f90FLAG=${F90FLAG}
+  export fFLAG=${FFLAG}
+
+  export LDFLAG="${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="-rv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_titane/Sitespecific_titane.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_titane/Sitespecific_titane.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_titane/Sitespecific_titane.h	(revision 1677)
@@ -0,0 +1,58 @@
+############### Site and OS dependent specifications ###########################
+#
+#                titane :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != titane ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a titane node '
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=X64
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE=""
+
+  export NETCDF_LIB="-L $NETCDF_LIB_DIR -lnetcdff -lnetcdf"
+  export NETCDF_INCLUDE=$NETCDF_INC_DIR
+
+
+  export LIB1=" -llapack -lblas "
+
+  export SYS_INCLUDE=./
+
+  if [ "$MAKETARGET" = "all" ] || [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'Compiler revision :'
+    echo ` mpif90 -V ` 
+  fi
+
+  export F90com=mpif90
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=cc
+  export ar=ar
+  export as=""
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_libs_vargas.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_libs_vargas.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_libs_vargas.h	(revision 1677)
@@ -0,0 +1,37 @@
+# Compile modes (specified by user): libraries on vargas
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc="-q64"
+    optf="-q64 -O3 -qextname=flush "
+    optf77="-q64 -O3 -qextname=flush "
+     optl="-q64  -O3"
+#    optl="-q64 -qextname -bmaxd:2000000000 -O3"
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-qrealsize=8"
+  optnh=""
+  lstflags=""
Index: CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_oasis3_vargas.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_oasis3_vargas.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_vargas/Compile_mode_oasis3_vargas.h	(revision 1677)
@@ -0,0 +1,37 @@
+# Compile modes (specified by user) : oasis3 on vargas 
+
+  if [ $compile_mode = default ];   then
+    optc="-q64" 
+    optf="-q64 -O3 -qextname=flush "
+    optf77="-q64 -O3 -qextname=flush "
+    optl="-q64 -O3"
+#    optl="-q64 -q extname -bmaxdata:2000000000 -O3"
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-qrealsize=8"
+  optnh=""
+  lstflags=""
+
Index: CPL/oasis3/trunk/util/compile/frames/include_vargas/OSspecific_vargas.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_vargas/OSspecific_vargas.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_vargas/OSspecific_vargas.h	(revision 1677)
@@ -0,0 +1,31 @@
+#
+#
+# `uname -n` : vargas 
+# `uname -s` : AIX
+# `uname -m` : 
+#
+  export CPPFLAG=""
+
+  export CPPFLAGF90start="-d -WF"
+  export CPPFLAGSEP=","
+
+####  lstflags="-qxlf90=nosignedzero"
+  export F90FLAG="${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG=${F90FLAG}" -qfixed -qsuffix=cpp=F"
+  export f90FLAG=${F90FLAG}" -qsuffix=cpp=f90"
+  export fFLAG=${F90FLAG}" -qfixed -qsuffix=cpp=f"
+  export F90FLAG=${F90FLAG}" -qsuffix=cpp=F90"
+
+  export LDFLAG="${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="ruv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_vargas/Sitespecific_vargas.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_vargas/Sitespecific_vargas.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_vargas/Sitespecific_vargas.h	(revision 1677)
@@ -0,0 +1,52 @@
+############### Site and OS dependent specifications ###########################
+#
+#                vargas :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != vargas ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a vargas node '
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=AIX6                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE="./"
+
+  export NETCDFROOT=/usr/local/pub/NetCDF/3.6.3
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=""
+
+  export SYS_INCLUDE=./
+
+  export F90com=mpxlf90_r
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=cc
+  export ar="ar"
+  export as="as"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
Index: CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_libs_zahir.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_libs_zahir.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_libs_zahir.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user): libraries on zahir
+#
+#     Note : - all libraries are compiled with -Pstack
+#            - the models use their own (stack/static) option 
+#            
+  if [ $compile_mode = default ];   then
+    optc="-q64"
+    optf="-q64 -O3"
+    optf77="-q64 -O3"
+    optl="-q64 -brename:.flush,.flush_ -bmaxd:2000000000 -O3"
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    echo "not yet possible"
+    exit 1
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-qrealsize=8"
+  optnh=""
+  lstflags=""
Index: CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_oasis3_zahir.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_oasis3_zahir.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_zahir/Compile_mode_oasis3_zahir.h	(revision 1677)
@@ -0,0 +1,36 @@
+# Compile modes (specified by user) : oasis3 on zahir 
+
+  if [ $compile_mode = default ];   then
+    optc="-q64" 
+    optf="-q64 -O3"
+    optf77="-q64 -O3"
+    optl="-q64 -brename:.flush,.flush_ -bmaxdata:2000000000 -O3"
+  elif [ $compile_mode = debug ];   then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = profile ]; then
+    optc=" "
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = opt ];     then
+    optc=""
+    optf=""
+    optf77=""
+    optl=""
+  elif [ $compile_mode = ad_hoc ];  then
+    echo "with this option the options are set through GUI input"
+    exit 1
+  else
+    echo "Invalid compile mode"
+    exit 1
+  fi
+
+# Other compile options
+
+  optdbl="-qrealsize=8"
+  optnh=""
+  lstflags=""
+
Index: CPL/oasis3/trunk/util/compile/frames/include_zahir/OSspecific_zahir.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_zahir/OSspecific_zahir.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_zahir/OSspecific_zahir.h	(revision 1677)
@@ -0,0 +1,31 @@
+#
+#
+# `uname -n` : zahir 
+# `uname -s` : AIX
+# `uname -m` : 
+#
+  export CPPFLAG=""
+
+  export CPPFLAGF90start="-d -WF"
+  export CPPFLAGSEP=","
+
+####  lstflags="-qxlf90=nosignedzero"
+  export F90FLAG="${optf} ${optdbl} ${optnh} ${lstflags}"    
+  export FFLAG=${F90FLAG}" -qfixed -qsuffix=cpp=F"
+  export f90FLAG=${F90FLAG}" -qsuffix=cpp=f90"
+  export fFLAG=${F90FLAG}" -qfixed -qsuffix=cpp=f"
+  export F90FLAG=${F90FLAG}" -qsuffix=cpp=F90"
+
+  export LDFLAG="${optl} ${optdbl} ${optnh}"
+
+  export CCFLAG=${optc}
+
+  export AFLAG="-h float0  -m"
+
+  export ARFLAG="ruv"
+
+  export MPPFLAG=" "
+
+  export I4mods="I"
+
+
Index: CPL/oasis3/trunk/util/compile/frames/include_zahir/Sitespecific_zahir.h
===================================================================
--- CPL/oasis3/trunk/util/compile/frames/include_zahir/Sitespecific_zahir.h	(revision 1677)
+++ CPL/oasis3/trunk/util/compile/frames/include_zahir/Sitespecific_zahir.h	(revision 1677)
@@ -0,0 +1,52 @@
+############### Site and OS dependent specifications ###########################
+#
+#                zahir :  part of name of header file
+#                NODE   : where the model is compiled
+
+  if   [ ${NODE} != zahir ]; then
+    echo ' The OS/Site dependent specifications are not for this machine.'
+    echo ' Node name of this machine:' ${NODE}
+    echo ' Script setup is for use on a zahir node '
+  if [ "$MAKETARGET" != "tar" ]; then
+    echo ' The task is stopped!'
+    exit 1
+  fi
+  fi
+
+  if [ "$MAKETARGET" = "lib" ]; then
+    echo ' '
+    echo 'No executable will be created. '
+  fi
+  export ARCH=AIX                                                                 
+  export BLDROOT=$SRCROOT/$ARCH
+
+  set +u
+  if [[ -z "$LD_LIBRARY_PATH0" ]]; then
+    LD_LIBRARY_PATH0=""
+  fi
+  set -u
+
+  export MPI_INCLUDE="./"
+
+  export NETCDFROOT=/usr/local/pub
+  export NETCDF_LIB="-L${NETCDFROOT}/lib -lnetcdf"
+  export NETCDF_INCLUDE=${NETCDFROOT}/include
+
+  export LIB1=""
+
+  export SYS_INCLUDE=./
+
+  export F90com=mpxlf90_r
+  export f90com=${F90com}
+  export Fcom=${F90com}
+  export fcom=${F90com}
+
+  export cc=cc
+  export ar="ar"
+  export as="as"
+  export cp=cp
+
+  PATH=$SRCROOT/util:$PATH
+
+  alias make="gmake"
+
