Index: trunk/LMDZ.GENERIC/README
===================================================================
--- trunk/LMDZ.GENERIC/README	(revision 987)
+++ trunk/LMDZ.GENERIC/README	(revision 988)
@@ -948,2 +948,14 @@
 - User manual (+ sources) added in DOC.
 
+== 12/06/2013 == EM
+- Moved "newstart" (and related "lect_start_archive.F") to phystd directory
+- Adapted makegcm_* scripts to enable compiling main prog from physics
+- Added in newstart the possibility to not read in any surface.nc file
+  (when loading a start_archive) with keyword "none" (instead of surface
+  file name)
+- Some general cleanup:
+  - in bibio: removed unused lmdstd.h readstd.F writestd.F mywrite.F 
+              readcoord.F scatter.F gather.F ini36.F from36.F to36.F
+              lnblnk.F (F90 len_trim() should be used instead)
+  - in dyn3d: removed unused inigrads.F wrgrads.F gradsdef.h
+              xvik.F (specific to current Mars)
Index: trunk/LMDZ.GENERIC/libf/bibio/from36.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/from36.F	(revision 987)
+++ 	(revision )
@@ -1,111 +1,0 @@
-      SUBROUTINE from36(x,nbre,iunit)
-      IMPLICIT NONE
-c====================================================================
-      INTEGER iunit, nbre
-      REAL x(nbre)
-c====================================================================
-      INTEGER i, l
-      INTEGER nbreok, ibaseok, icase
-      REAL xmax, xmin, errcod
-c====================================================================
-      INTEGER lbord
-      PARAMETER (lbord=255)
-      REAL conv(0:lbord)
-c====================================================================     
-      INTEGER ibase, maxcas, maxnbr, ifact1, ifact2, ifact3
-      PARAMETER (ibase=36, maxcas=3, maxnbr=100000)
-      PARAMETER(ifact1=ibase**1-1)
-      PARAMETER(ifact2=ibase**2-1)
-      PARAMETER(ifact3=ibase**3-1)
-      CHARACTER*1 base(ibase), fac(maxcas,maxnbr)
-      INTEGER inte(maxcas)
-      DATA (base(l),l=1,ibase)
-     .     /'0','1','2','3','4','5','6','7','8','9',
-     .      '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'/
-c====================================================================
-      IF (nbre .GT. maxnbr) THEN
-      PRINT*, 'Verifier maxnbr dans from36 (trop petite)'
-      STOP
-      ENDIF
-      DO 10 i = 0, lbord
-   10 conv(i) = 1.0e+33
-c    34  c  10 conv(i) = 1.0e+49
-      DO 20 i = 1, ibase
-      l = ICHAR(base(i))
-   20 conv(l) = FLOAT(i-1)
-c====================================================================
-      READ (iunit,*) nbreok, ibaseok, icase
-        IF (nbre .NE. nbreok) THEN
-          PRINT*, 'Incoherence (Nombre elements)', nbreok, nbre
-          STOP
-        ENDIF
-        IF (ibase .NE. ibaseok) THEN
-          PRINT*, 'Incoherence (Nombre base)', ibaseok, ibase
-          STOP
-        ENDIF
-        IF (icase.NE.1 .AND. icase.NE.2 .AND. icase.NE.3) THEN
-          PRINT*, 'Verifier icase (1,2,3) dans le fichier a lire', 
-     .             icase
-          STOP
-        ENDIF
-c====================================================================
-      READ (iunit,*) xmin
-      READ (iunit,*) xmax
-        PRINT*,'Xmin et Xmax=', xmin, xmax
-c====================================================================
-      IF (xmin .EQ. xmax) THEN
-        READ(iunit,'(a)')
-        PRINT*, 'Ce champ est constant'
-        DO 30 i = 1, nbre
-   30   x(i) = xmin
-        GO TO 123
-      END IF
-c====================================================================
-      IF (icase .EQ. 1) THEN
-        errcod = (xmax-xmin) / FLOAT(ifact1)
-        PRINT*,'La precision du codage est entre + / - ', errcod
-        READ(iunit,91)((fac(l,i),l=1,icase),i=1,nbre)
-        DO 190 i = 1, nbre
-        x(i) = 0.0
-        DO 191 l = 1, icase
-        inte(l) = ICHAR( fac(l,i) )
-        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
-  191   CONTINUE
-        x(i) = xmin + x(i)/FLOAT(ifact1)*(xmax-xmin)
-  190   CONTINUE
-      ELSE IF (icase .EQ. 2) THEN
-        errcod = (xmax-xmin) / FLOAT(ifact2)
-        PRINT*,'La precision du codage est entre + / - ', errcod
-        READ(iunit,92)((fac(l,i),l=1,icase),i=1,nbre)
-        DO 290 i = 1, nbre
-        x(i) = 0.0
-        DO 291 l = 1, icase
-        inte(l) = ICHAR( fac(l,i) )
-        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
-  291   CONTINUE
-        x(i) = xmin + x(i)/float(ifact2)*(xmax-xmin)
-  290   CONTINUE
-      ELSE IF (icase .EQ. 3) THEN
-        errcod = (xmax-xmin) / FLOAT(ifact3)
-        PRINT*,'La precision du codage est entre + / - ', errcod
-        READ(iunit,93)((fac(l,i),l=1,icase),i=1,nbre)
-        DO 390 i = 1, nbre
-        x(i) = 0.0
-        DO 391 l = 1, icase
-        inte(l) = ICHAR( fac(l,i) )
-        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
-  391   CONTINUE
-        x(i) = xmin + x(i)/FLOAT(ifact3)*(xmax-xmin)
-  390   CONTINUE
-      ELSE
-        PRINT*, 'Verfier icase (1, 2 ou 3)'
-        STOP
-      ENDIF
-   91 FORMAT(120a1)
-   92 FORMAT(64(2a1))
-   93 FORMAT(40(3a1))
-c====================================================================
-  123 RETURN
-      END
Index: trunk/LMDZ.GENERIC/libf/bibio/gather.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/gather.F	(revision 987)
+++ 	(revision )
@@ -1,16 +1,0 @@
-      SUBROUTINE GATHER(n,a,b,index)
-c
-      IMPLICIT NONE
-C
-      INTEGER n,index(n),i
-      REAL a(n),b(n)
-c
-      DO 100 i=1,n
-        a(i)=b(index(i))
-100   CONTINUE
-c
-      RETURN
-      END
-c
-c     voir aussi vec_gather(v,vindices,count,r)...p.11-14
-c  
Index: trunk/LMDZ.GENERIC/libf/bibio/ini36.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/ini36.F	(revision 987)
+++ 	(revision )
@@ -1,46 +1,0 @@
-      SUBROUTINE ini36
-Ccray IMPLICIT NONE
-      IMPLICIT NONE
-c====================================================================
-c-- cette routine fait l'initialisation pour le codage sur base 36
-c-- de la routine to36. on peut utiliser soit 1 soit 2 soit 3 cases
-      INTEGER i,j,k,l, ijk, jk
-c====================================================================
-      INTEGER ibase, ifact1, ifact2, ifact3
-      PARAMETER (ibase=36)
-      PARAMETER (ifact1 = ibase-1)
-      PARAMETER (ifact2 = ibase*ibase-1)
-      PARAMETER (ifact3 = ibase*ibase*ibase-1)
-c====================================================================
-      CHARACTER*1 word1(0:ifact1)
-      COMMON /elbat1/ word1
-      CHARACTER*2 word2(0:ifact2)
-      COMMON /elbat2/ word2
-      CHARACTER*3 word3(0:ifact3)
-      COMMON /elbat3/ word3
-c====================================================================
-      CHARACTER*1 base(ibase)
-      DATA (base(l),l=1,ibase)
-     .     /'0','1','2','3','4','5','6','7','8','9',
-     .      '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'/
-c===================================================================
-      DO 30 i = 1, ibase
-      DO 30 j = 1, ibase
-      DO 30 k = 1, ibase
-      ijk = ( (i-1)*ibase + j-1 )*ibase + k-1
-      word3(ijk) = base(i)//base(j)//base(k)
-   30 CONTINUE
-      DO 20 j = 1, ibase
-      DO 20 k = 1, ibase
-      jk = (j-1)*ibase + k-1
-      word2(jk) = base(j)//base(k)
-   20 CONTINUE
-      DO 10 k = 1, ibase
-      word1(k-1) = base(k)
-   10 CONTINUE
-c===================================================================
-      RETURN
-      END
-
Index: trunk/LMDZ.GENERIC/libf/bibio/lmdstd.h
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/lmdstd.h	(revision 987)
+++ 	(revision )
@@ -1,31 +1,0 @@
-c=======================================================================
-c   INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
-
-      INTEGER bandmax
-      PARAMETER(bandmax=24)
-
-      COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
-     $                gentete,gdatedep,gdatefin
-        
-      CHARACTER*100 gtitre    !du champ
-      CHARACTER*20  gunites   !unites du champ
-      CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
-      CHARACTER*100 gfichier  !nom du fichier contenant le champ
-      CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
-      CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
-      CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
-      CHARACTER*20  glistfich !liste de champs a sortir
-
-      COMMON/lmdstdnu/ gminimum,gmaximum,
-     $                 gdeltajour(bandmax),gdeltapas(bandmax),
-     $                 gnbetats(bandmax),gnbfich
-
-      REAL    gminimum        ! \    min et max
-      REAL    gmaximum        ! /    du champ
-      INTEGER gnbfich         ! nombre de fichier a sortir
-c  pour les evolutions temporelles:
-      INTEGER gnbetats        ! nombre d'etats par bande
-      INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
-      REAL    gdeltajour      ! ecart en jour des sorties sur bandes
-
-c=======================================================================
Index: trunk/LMDZ.GENERIC/libf/bibio/lnblnk.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/lnblnk.F	(revision 987)
+++ 	(revision )
@@ -1,36 +1,0 @@
-      INTEGER FUNCTION lnblnk (letter)
-
-C--------------------------------------------------------
-C Fonction qui determine la longeur d'un string sans les
-C blancs qui suivent. Le critere pour determiner la fin du
-C string est, trois blancs de suite
-C---------------------------------------------------------
-C     ARGUMENTS
-C     +++++++++
-C     letter: CHARACTER*xxx (xxx < imax)
-C             le string dont on determine la longuer
-C     lnblnk: INTEGER
-C             le nombre de characteres
-C
-C     PARAMETER
-C     +++++++++
-C     imax : INTEGER
-C            le nombre maximale de character que peut contenir le string
-C            a traiter
-
-      IMPLICIT NONE
-      INTEGER i,imax
-      PARAMETER (imax = 256)
-      CHARACTER*256 letter
-
-      i=0
-
-10    i=i+1
-      IF (letter(i:i+3) . EQ . '   ') GOTO 20
-      GOTO 10
-
-20    lnblnk=i-1
-
-      RETURN
-      END
-
Index: trunk/LMDZ.GENERIC/libf/bibio/mywrite.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/mywrite.F	(revision 987)
+++ 	(revision )
@@ -1,154 +1,0 @@
-      SUBROUTINE mywrite(champ,icount,titre,unit,format,nom
-     &                  , entete, date0, date, deltpas, nbeta
-     &                  , deltajour, filenum, files)
-C----------------------------------------------------------
-C Subroutine qui ecrit les fichiers dans le format de transfert
-C vers le LMD.
-C format etabli par Zhao-Xin Li, Frederique Hourdin, Emmanuelle Cohen-Solal,
-C Jan Polcher . Il peut etre utilise pour sortire  des evolutions
-C temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
-C le character # place devant le format determine la fin de la 
-C description du champ et permet eventulellement de rajouter
-C des informations (avant le #).
-C le programme de lecture lit , dans la description, les variables
-C qu'il connait et saute apres jusquau #. A partir de la
-C il commence a lire le champ dans le format specifie.
-c------------------------------------------------------------
-C       ARGUMENTS
-C       +++++++++
-C champ: REAL (icount)
-C        champ contenant les valeurs et de longeur icount
-C icount: INTEGER
-C         nombre d'element dans le champ
-C titre: CHARACTER*100
-C        nom d'ecrivant le champ
-C unit: CHARACTER*20
-C       unites du champ
-C format: CHARACTER*20
-C         format dans le quel le champ doit etre ecrit.
-C         au choix:
-C                  - tous les format FORTRAN
-C                  - compactage de L.Li (zxliN) ou N peut valoir 1, 2 ou 3
-C nom: CHARACTER*20
-C      nom du fichier dans le quel le champ sera ecris, eventuellement
-C      avec directory (ex: evol/tsol)
-C entete: CHARACTER*100
-C         une entete du fichier pouvant par exemple decrire le run
-C date0: CHARACTER*8
-C        date de depart de la moyenne ou de l'evolution temporelle que contient
-C        le fichier
-C date : CHARACTER*8
-C        date de fin de la moyenne ou de l'evolution temporelle que contient
-C        le fichier
-C deltpas: INTEGER (bandmax)
-C          decript le nombre de pas de temps entre deux sorties pour chamque
-C          bande (necesaire pour les evolutions temporelles)
-C nbeta: INTEGER (bandmax)
-C        donne le nombre d'etas par bande (necesaire pour les evolutions 
-C        temporelles)
-C deltajour: REAL (bandmax)
-C             l'ecart en jours des iscriptions sur chaque bande (necesaire 
-C             pour les evolutions temporelles)
-C filenum: INTEGER
-C          nombre d'elements dans la liste files des champs desires
-C          si filenum = 0 alors tous les champs sont sortis  
-C files: CHARACTER*20 (100)
-C        list des champ que l'on desire sortire
-C
-C        PARAMETER
-C        +++++++++
-C bandmax: INTEGER
-C          le nombre maximale que peut traiter le programme
-C
-
-
-      IMPLICIT NONE
-
-      INTEGER bandmax
-      PARAMETER (bandmax = 24)
-      INTEGER icount,i,imin,imax
-      REAL champ(icount)
-      CHARACTER*100 titre, entete
-      CHARACTER unit*20,nom*80
-      CHARACTER*20 format
-      CHARACTER*8 date0, date
-      INTEGER deltpas(bandmax), nbeta(bandmax)
-      REAL deltajour(bandmax)
-      LOGICAL check, writeornot
-      INTEGER lnblnk,ismin,ismax
-      INTEGER filenum
-      CHARACTER*20 files(100)
-      EXTERNAL lnblnk,ismin,ismax, isitor, to36
-
-      check = .FALSE.
-
-      IF (filenum .EQ. 0) THEN
-        writeornot = .TRUE.
-      ELSE
-        CALL isitor(nom,writeornot,filenum, files)
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'MYWRITE:: writeornot=',writeornot
-      ENDIF
-
-      IF (writeornot) THEN
-      imin = ismin(icount,champ,1)
-      imax = ismax(icount,champ,1)
-      IF (check) THEN
-        WRITE(*,*) entete(1:lnblnk(entete))
-        WRITE(*,*) titre(1:lnblnk(titre))
-        WRITE(*,*) date0
-        WRITE(*,*) date
-        WRITE(*,*) unit(1:lnblnk(unit))
-        WRITE(*,*) deltpas, nbeta
-        WRITE(*,*) deltajour
-        WRITE(*,*) champ(imin),champ(imax)
-        WRITE(*,*) format(1:lnblnk(format))
-        WRITE(*,*) icount
-      ENDIF
-      WRITE(*,*) titre(1:lnblnk(titre)),'min,max:',
-     &           champ(imin),champ(imax),'  ',unit(1:lnblnk(unit))
-      
-      OPEN (unit=55, file=nom(1:lnblnk(nom)))
-      WRITE(55,'(a)') entete(1:lnblnk(entete))
-      WRITE(55,'(a)') titre(1:lnblnk(titre))
-      WRITE(55,'(a)') date0
-      WRITE(55,'(a)') date
-      WRITE(55,'(a)') unit(1:lnblnk(unit))
-      WRITE(55,*) deltpas, nbeta
-      WRITE(55,*) deltajour
-      WRITE(55,*) champ(imin),champ(imax)
-      WRITE(55,'(a)') '#'//format(1:lnblnk(format))
-      WRITE(55,*) icount
-
-      IF (check) THEN
-        WRITE(*,'('//format(1:lnblnk(format))//')') champ(1)
-      ENDIF
-
-      IF (format(1:lnblnk(format)) .EQ. 'zxli1') THEN
-        CALL to36 (champ,icount,champ(imin),champ(imax),55, 1)
-      ELSE 
-        IF (format(1:lnblnk(format)) .EQ. 'zxli2') THEN
-          CALL to36 (champ, icount,champ(imin), champ(imax),55, 2)
-        ELSE
-          IF (format(1:lnblnk(format)) .EQ. 'zxli3') THEN
-            CALL to36 (champ,icount,champ(imin),champ(imax),55, 3)
-          ELSE
-            DO 2233 i=1,icount
-              WRITE(55,'('//format(1:lnblnk(format))//')') 
-     &             champ(i)
- 2233       CONTINUE
-          ENDIF
-        ENDIF
-      ENDIF
-
-      CLOSE (unit=55)
-
-      ELSE
-        WRITE(*,*) 'FILE    ',nom,'WAS NOT WRITEN'
-      ENDIF
-      
-      RETURN
-      END
-
Index: trunk/LMDZ.GENERIC/libf/bibio/readcoord.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/readcoord.F	(revision 987)
+++ 	(revision )
@@ -1,123 +1,0 @@
-      SUBROUTINE readcoord(imx,jmx,lmx,imax,jmax,lmax,x,y,z,pathcoor)
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteurs Jan Polcher, Frederic Hourdin
-c   -------
-c
-c   Objet   Lecture du fichier contenant des coordonnees x,y et z.
-c   -----
-c
-c   Inteface
-c   --------
-c
-c   Arguments:
-c   ----------
-c
-c   input
-c   -----
-c      imx   \
-c      jmx          dimensions des coordonnees
-c      lmx   /
-c      pathcoor     path absolu pour le fichier des coordonnees
-c                   CHARACTER*80
-c
-c   ouput
-c   -----
-c      imax         nombre de coordonnees x effectives
-c      jmax         nombre de coordonnees y effectives
-c      lmax         nombre de coordonnees z effectives
-c      x(imx)
-c      y(jmx)
-c      z(lmx)
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-c   arguments:
-c   ----------
-
-      INTEGER imx,jmx,lmx
-      INTEGER imax,jmax,lmax
-
-      REAL x(imx),y(jmx),z(lmx)
-
-      CHARACTER*80 pathcoor
-
-c   local
-c   -----
-
-      INTEGER i,j,l
-
-      CHARACTER*100 filecoor,messerr
-
-      EXTERNAL lnblnk
-      INTEGER lnblnk
-
-c-----------------------------------------------------------------------
-c   Initialisations:
-c   ----------------
-
-      messerr=' '
-      filecoor='coord.def'
-
-c-----------------------------------------------------------------------
-
-100   IF(pathcoor(1:1).EQ.'/') THEN
-         filecoor= pathcoor(:lnblnk(pathcoor))//filecoor
-      ENDIF
-      OPEN (99,file=filecoor,err=200,status='old',form='formatted')
-      GO TO 300
-
-200   WRITE(*,*) messerr
-      WRITE(*,*) 'entrer le nom du fichier des coordonnees puis RETURN'
-      WRITE(*,*) 'ou seulement RETURN pour arreter le programme'
-      READ(*,'(a)') filecoor
-      IF(filecoor(1:1).EQ.' ') STOP
-      CLOSE (99)
-      GOTO 100
-
-300   CONTINUE
-
-      READ(99,*,err=9999) imax
-      IF(imax.GT.imx) THEN
-        WRITE(6,1000) 'x',imx,imax
-        STOP
-      ENDIF
-      READ(99,*) (x(i),i=1,imax)
-
-      READ(99,*,err=9999) jmax
-      IF(jmax.GT.jmx) THEN
-        WRITE(6,1000) 'y',jmx,jmax
-        STOP
-      ENDIF
-      READ(99,*,err=9999) (y(j),j=1,jmax)
-
-      READ(99,*,err=9999) lmax
-      IF(lmax.GT.lmx) THEN
-        WRITE(6,1000) 'z',lmx,lmax
-        STOP
-      ENDIF
-      READ(99,*) (z(l),l=1,lmax)
-
-      CLOSE(99)
-
-c-----------------------------------------------------------------------
-
-      RETURN
-
-9999  PRINT*,'Le fichier ',filecoor,' que vous lisez est mal structure'
-      PRINT*,'Il doit contenir :'
-      PRINT*,'  le nombre de points en x suivi des valeurs de x'
-      PRINT*,'  puis la meme chose pour y et z'
-      STOP
-
-1000  FORMAT(/,
-     $ 'Probleme avec le fichier de coordonnees',/,
-     $ 'Le tableau contenant ',a3,' est dimenssionne a ',i4,/,
-     $ 'et le fichier de coordonnees contient ',i4,' valeurs.')
-
-      END
Index: trunk/LMDZ.GENERIC/libf/bibio/readstd.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/readstd.F	(revision 987)
+++ 	(revision )
@@ -1,286 +1,0 @@
-      SUBROUTINE readstd(imx,champ,imax)
-      IMPLICIT NONE
-
-c=======================================================================
-c
-c   Auteurs:   Jan Polcher, Frederic Hourdin  20/04/91
-c   --------
-c
-c   Objet:
-c   ------
-c
-c Subroutine qui lit les fichiers dans le format lmdstd
-c format etabli par :
-c  Jan Polcher,Zhao-Xin Li, Frederic Hourdin, Emmanuelle Cohen-Solal,
-c Il peut etre utilise pour sortire  des evolutions
-c temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
-c le character # place devant le format determine la fin de la 
-c description du champ et permet eventulellement de rajouter
-c des informations (avant le #).
-c le programme de lecture lit , dans la description, les variables
-c qu'il connait et saute apres jusquau #. A partir de la
-c il commence a lire le champ dans le format specifie.
-c
-c-----------------------------------------------------------------------
-c
-c   Interface:
-c   ----------
-c
-c   ARGUMENTS
-c   ---------
-c
-c imx  : INTEGER
-c        taille du tableau contenant le champ
-c champ: REAL (imx)
-c        champ contenant les valeurs et de longeur icount
-c imax : INTEGER
-c        nombre d'element dans le champ
-c
-c   COMMON:
-c   -------
-c
-c=======================================================================
-c  INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
-c
-c     INTEGER bandmax
-c     PARAMETER(bandmax=24)
-c
-c     COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
-c    $                gentete,gdatedep,gdatefin
-c       
-c     CHARACTER*100 gtitre    !du champ
-c     CHARACTER*20  gunites   !unites du champ
-c     CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
-c     CHARACTER*100 gfichier  !nom du fichier contenant le champ
-c     CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
-c     CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
-c     CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
-c     CHARACTER*20  glistfich !liste de champs a sortir
-c
-c     COMMON/lmdstdnu/ gminimum,gmaximum,
-c    $                 gdeltajour(bandmax),gdeltapas(bandmax),
-c    $                 gnbetats(bandmax),gnbfich
-c
-c     REAL    gminimum        ! \    min et max
-c     REAL    gmaximum        ! /    du champ
-c     INTEGER gnbfich         ! nombre de fichier a sortir
-c pour les evolutions temporelles:
-c     INTEGER gnbetats        ! nombre d'etats par bande
-c     INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
-c     REAL    gdeltajour      ! ecart en jour des sorties sur bandes
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-#include "lmdstd.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER imx,imax
-      REAL champ(imx)
-
-c   Local:
-c   ------
-
-      INTEGER i
-
-      CHARACTER*200 test(20)
-      CHARACTER*200 helptest(20)
-      CHARACTER*200 help
-      INTEGER reccount
-
-      LOGICAL check,continue
-
-      EXTERNAL lnblnk
-      INTEGER lnblnk
-
-c-----------------------------------------------------------------------
-c   Initialisations:
-c   ----------------
-
-      check = .FALSE.
-      DO 9876 i=1,20
-        helptest(i) = '        '
- 9876 CONTINUE
-
-
-c-----------------------------------------------------------------------
-c   lecture le l'entete:
-c   --------------------
-
- 2222 OPEN (unit=10,file=gfichier(1:lnblnk(gfichier)), form='formatted',
-     &      ERR = 9999, status='old')
-      GOTO 1111
-
- 9999 WRITE(*,*) 'Je ne peut pas lire le fichier: ',
-     & gfichier(1:lnblnk(gfichier))
-      CLOSE(10)
-      WRITE(*,*) 'Entrez S.V.P. un autre nom de fichier (path absolu) '
-      WRITE(*,*) 'ou RETURN pour stopper lexecution'
-      READ (*,'(a)') gfichier
-      IF(lnblnk(gfichier).EQ.0) STOP
-      GOTO 2222
-
- 1111 continue = .TRUE.
-      DO 2345 i=1,20
-        IF (continue) THEN
-          READ (10,'(a200)') test(i)
-          IF ( test(i)(1:1) .EQ. '#' .OR. test(i)(1:1) .EQ. 'f10' ) THEN
-            continue = .FALSE.
-            reccount = i
-          ENDIF
-        ENDIF
- 2345 CONTINUE
-
-      DO 1223 i=1,reccount-1
-        helptest(i) = test(i)
- 1223 CONTINUE
-      helptest(20) = test(reccount)
-
-
-      IF (check) THEN
-        WRITE(*,*) 'gentete'
-      ENDIF
-      IF ( helptest(1) .NE. ' ' ) THEN
-        read (helptest(1),'(a100)') gentete
-      ELSE
-c       WRITE(*,*) 'la description du run'
-c       READ (*,'(a100)') gentete
-        gentete = '    '
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'titre'
-      ENDIF
-      IF ( helptest(2) .NE. ' ' ) THEN
-        read (helptest(2),'(a100)') gtitre
-      ELSE
-c       WRITE(*,*) 'le titre du dessin'
-c       READ (*,'(a100)') gtitre 
-        gtitre = '    '
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'datefins'
-      ENDIF
-      IF ( helptest(3) .NE. ' ' ) THEN
-        read (helptest(3),'(a8)') gdatedep 
-        read (helptest(4),'(a8)') gdatefin
-      ELSE
-c       WRITE(*,*)
-c    &  'datefin du debut de la moyenne (ou le mois tout simplement)'
-c       READ (*,'(a8)') gdatedep 
-c       WRITE(*,*) 'et celle de la fin (ou rien du tout)'
-c       READ (*,'(a8)') gdatefin 
-        gdatedep = '       '
-        gdatefin = '       '
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'unitees'
-      ENDIF
-      IF ( helptest(5) .NE. ' ' ) THEN
-        read (helptest(5),'(a20)') gunites
-      ELSE
-c       WRITE(*,*) 'les unitees du champ'
-c       READ (*,'(a20)') gunites
-        gunites = '                    '
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'deltapas et nbetats'
-      ENDIF
-      IF ( helptest(6) .NE. ' ' ) THEN
-c       READ (helptest(6),*,ERR=1212) 
-c    .       (gdeltapas(i),i=1,bandmax),(gnbetats(i),i=1,bandmax)
-        GOTO 1213
-
- 1212   help =helptest(6)(1:lnblnk(helptest(6)))//
-     .        helptest(7)(1:lnblnk(helptest(7)))
-        helptest(6) = help
-        IF (check) THEN
-          WRITE(*,*) 'Problems while reading', help
-        ENDIF
-        DO  1214 i=7,reccount
-          helptest(i) = helptest(i+1)
- 1214   CONTINUE
-c       READ (helptest(6),*,ERR=1212) 
-c    .       (gdeltapas(i),i=1,bandmax),(gnbetats(i),i=1,bandmax)
-
- 1213   CONTINUE
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'deltajour'
-      ENDIF
-      IF ( helptest(7) .NE. ' ' ) THEN
-c       READ (helptest(7),*,ERR=1312) (gdeltajour(i),i=1,bandmax)
-        GOTO 1313
-
- 1312   help =helptest(7)(1:lnblnk(helptest(7)))//
-     .        helptest(8)(1:lnblnk(helptest(8)))
-        helptest(7) = help
-        IF (check) THEN
-          WRITE(*,*) 'Problems while reading', help
-        ENDIF
-        DO  1314 i=8,reccount
-          helptest(i) = helptest(i+1)
- 1314   CONTINUE
-c       READ (helptest(7),*,ERR=1312) (gdeltajour(i),i=1,bandmax)
-
- 1313   CONTINUE
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'min et max'
-      ENDIF
-      IF ( helptest(8) .NE. ' ' ) THEN
-c       READ (helptest(8),*)     gminimum,gmaximum
-      ENDIF
-
-      gformat = helptest(20)(2:20)
-
-      IF (check) THEN
-        WRITE(*,*) gentete
-        WRITE(*,*) gtitre
-        WRITE(*,*) gdatedep
-        WRITE(*,*) gdatefin 
-        WRITE(*,*) gdeltapas,gnbetats
-        WRITE(*,*) gdeltajour
-        WRITE(*,*) gminimum,gmaximum
-        WRITE(*,*) gformat
-      ENDIF
-
-c-----------------------------------------------------------------------
-c   lecture du champ proprement dit:
-c   --------------------------------
-
-      READ (10,*)     imax
-   
-      IF(imax.GT.imx) THEN
-         WRITE(*,*) 'Vous essayez de lire un champ dont la taille est'
-         WRITE(*,*) 'superieure a la taille maximum autorisee'
-         WRITE(*,*) 'c est a dire a la dimension du champ utilise'
-         WRITE(*,*) 'pour lappel a la procedure writestd.'
-         STOP
-      ENDIF
-
-      IF (gformat(1:4) .EQ. 'zxli') THEN
-        CALL from36 (champ,imax,10)
-      ELSE 
-         IF (lnblnk(gformat).LE.1.OR.lnblnk(gformat).GE.20) THEN
-            READ(10,*) (champ (i),i=1,imax)
-         ELSE
-            READ(10,'('//gformat(1:lnblnk(gformat))//')')
-     $      (champ (i),i=1,imax)
-         ENDIF
-      ENDIF
-
-      CLOSE (unit=10)
-
-
-      RETURN
-      END
Index: trunk/LMDZ.GENERIC/libf/bibio/scatter.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/scatter.F	(revision 987)
+++ 	(revision )
@@ -1,21 +1,0 @@
-       subroutine scatter(n,a,index,b)
-C
-       implicit none
-       integer N,INDEX(n),I
-       real A(n),B(n)
-c
-c
-       DO 100 I=1,N
-          A(INDEX(I))=B(I)
-100    CONTINUE
-c
-       return
-       end 
-c
-c
-c      peut etre vec_scatter(v,rindices,count,r) en f77hp
-c      equivalent code:
-c      do 99 i=1,count
-c99    r(rindices(i))=v(i)
-c      voir p. 11-13
-c
Index: trunk/LMDZ.GENERIC/libf/bibio/to36.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/to36.F	(revision 987)
+++ 	(revision )
@@ -1,84 +1,0 @@
-      SUBROUTINE to36(x,nbre,xmin,xmax,iunit,icase)
-Ccray IMPLICIT NONE
-      IMPLICIT NONE
-c=======================================================================
-c-- x    : le champ a compacter
-c-- nbre : la taille du champ x
-c-- iunit: numero logique du fichier sortie
-c-- icase: nombre de cases a utiliser (qui determine la precision)
-      INTEGER iunit, nbre, icase
-      REAL x(nbre) 
-c=======================================================================
-      INTEGER ibase, maxnbr, ifact1, ifact2, ifact3
-      PARAMETER (ibase=36, maxnbr=100000)
-      PARAMETER (ifact1 = ibase**1-1)
-      PARAMETER (ifact2 = ibase**2-1)
-      PARAMETER (ifact3 = ibase**3-1)
-c=======================================================================
-      CHARACTER*1 word1(0:ifact1)
-      COMMON /elbat1/ word1
-      CHARACTER*1 chax1(maxnbr)
-c======================================================================
-      CHARACTER*2 word2(0:ifact2)
-      COMMON /elbat2/ word2
-      CHARACTER*2 chax2(maxnbr)
-c======================================================================
-      CHARACTER*3 word3(0:ifact3)
-      COMMON /elbat3/ word3
-      CHARACTER*3 chax3(maxnbr)
-c=====================================================================
-      INTEGER i, inte
-      REAL xmin, xmax
-      EXTERNAL ini36
-c=====================================================================
-c
-c--- initialisation pour le codage
-c la routine ini36 est appelee une seule fois
-c     IF (word1(36) .NE. 'Z' ) THEN
-        CALL ini36
-c     ENDIF
-
-      IF (nbre .GT. maxnbr) THEN
-        PRINT*, 'Nombre elements trop grand', nbre, maxnbr
-        STOP
-      ENDIF
-c
-      WRITE(iunit,*) nbre, ibase, icase, '  (nbre,ibase,icase)'
-      WRITE(iunit,*) xmin
-      WRITE(iunit,*) xmax
-c
-      IF(xmin .EQ. xmax)THEN
-      WRITE(iunit,'(a)')'Ce champ est constant'
-      GO TO 999
-      ENDIF 
-c
-      IF (icase .EQ. 1) THEN
-        DO 10 i = 1, nbre
-          inte = NINT( FLOAT(ifact1)/(xmax-xmin) * (x(i)-xmin) )
-          chax1(i) = word1(inte)
-   10   CONTINUE
-        WRITE(iunit,91) (chax1(i),i=1,nbre)
-      ELSE IF (icase .EQ. 2) THEN
-        DO 20 i = 1, nbre
-          inte = NINT( FLOAT(ifact2)/(xmax-xmin) * (x(i)-xmin) )
-          chax2(i) = word2(inte)
-   20   CONTINUE
-        WRITE(iunit,92) (chax2(i),i=1,nbre)
-      ELSE IF (icase.eq.3) THEN
-        DO 30 i = 1, nbre
-          inte = NINT( FLOAT(ifact3)/(xmax-xmin) * (x(i)-xmin) )
-          chax3(i) = word3(inte)
-   30   CONTINUE
-        WRITE(iunit,93) (chax3(i),i=1,nbre)
-      ELSE
-        PRINT*, 'Verfier icase (1,2,3) dans les arguments de to36'
-        STOP
-      ENDIF
-c
-   91 FORMAT(120a1)
-   92 FORMAT(64a2)
-   93 FORMAT(40a3)
-c
-  999 RETURN
-      END 
-
Index: trunk/LMDZ.GENERIC/libf/bibio/writestd.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/bibio/writestd.F	(revision 987)
+++ 	(revision )
@@ -1,200 +1,0 @@
-      SUBROUTINE writestd(champ,icount)
-
-c=======================================================================
-c
-c   Auteurs:   Jan Polcher, Frederic Hourdin
-c   --------
-c
-c   Objet:
-c   ------
-c
-c Subroutine qui ecrit les fichiers dans le format de transfert
-c vers le LMD.
-c format etabli par :
-c   Zhao-Xin Li, Frederic Hourdin, Emmanuelle Cohen-Solal,
-c   Jan Polcher .
-c Il peut etre utilise pour sortire  des evolutions
-c temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
-c le character # place devant le format determine la fin de la 
-c description du champ et permet eventulellement de rajouter
-c des informations (avant le #).
-c le programme de lecture lit , dans la description, les variables
-c qu'il connait et saute apres jusquau #. A partir de la
-c il commence a lire le champ dans le format specifie.
-c
-c-----------------------------------------------------------------------
-c
-c   Interface:
-c   ----------
-c
-c   ARGUMENTS
-c   ---------
-c
-c champ: REAL (icount)
-c        champ contenant les valeurs et de longeur icount
-c icount: INTEGER
-c        nombre d'element dans le champ
-c
-c   COMMON:
-c   -------
-c
-c=======================================================================
-c  INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
-c
-c     INTEGER bandmax
-c     PARAMETER(bandmax=24)
-c
-c     COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
-c    $                gentete,gdatedep,gdatefin
-c       
-c     CHARACTER*100 gtitre    !du champ
-c     CHARACTER*20  gunites   !unites du champ
-c     CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
-c     CHARACTER*100 gfichier  !nom du fichier contenant le champ
-c     CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
-c     CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
-c     CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
-c     CHARACTER*20  glistfich !liste de champs a sortir
-c
-c     COMMON/lmdstdnu/ gminimum,gmaximum,
-c    $                 gdeltajour(bandmax),gdeltapas(bandmax),
-c    $                 gnbetats(bandmax),gnbfich
-c
-c     REAL    gminimum        ! \    min et max
-c     REAL    gmaximum        ! /    du champ
-c     INTEGER gnbfich         ! nombre de fichier a sortir
-c pour les evolutions temporelles:
-c     INTEGER gnbetats        ! nombre d'etats par bande
-c     INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
-c     REAL    gdeltajour      ! ecart en jour des sorties sur bandes
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-      IMPLICIT NONE
-#include "lmdstd.h"
-
-c   Arguments:
-c   ----------
-
-      INTEGER icount
-      REAL champ(icount)
-
-c   Local:
-c   ------
-
-      INTEGER i,imin,imax
-      LOGICAL check, writeornot
-      INTEGER lnblnk,ismin,ismax
-      EXTERNAL lnblnk,ismin,ismax, isitor, to36
-
-      INTEGER indexfil
-      COMMON/indexfil/indexfil
-
-c-----------------------------------------------------------------------
-c   verification que le champ est dans la liste predefinie:
-c   -------------------------------------------------------
-
-      check = .FALSE.
-
-      IF (gnbfich .EQ. 0) THEN
-        writeornot = .TRUE.
-      ELSE
-        CALL isitor(gfichier,writeornot,gnbfich, glistfich)
-      ENDIF
-
-      IF (check) THEN
-        WRITE(*,*) 'MYWRITE:: writeornot=',writeornot
-      ENDIF
-
-c-----------------------------------------------------------------------
-      IF (writeornot) THEN
-c-----------------------------------------------------------------------
-
-      imin = ismin(icount,champ,1)
-      imax = ismax(icount,champ,1)
-      IF (check) THEN
-        WRITE(*,*) gentete(1:lnblnk(gentete))
-        WRITE(*,*) gtitre(1:lnblnk(gtitre))
-        WRITE(*,*) gdatedep
-        WRITE(*,*) gdatefin
-        WRITE(*,*) gunites(1:lnblnk(gunites))
-        WRITE(*,*) gdeltapas, gnbetats
-        WRITE(*,*) gdeltajour
-        WRITE(*,*) champ(imin),champ(imax)
-        WRITE(*,*) gformat(1:lnblnk(gformat))
-        WRITE(*,*) icount
-      ENDIF
-      WRITE(*,*) gtitre(1:lnblnk(gtitre)),'min,max:',
-     &  champ(imin),champ(imax),'  ',gunites(1:lnblnk(gunites))
-      
-c-----------------------------------------------------------------------
-c   creation eventuelle d'un nom pour le fichier d'ecriture du champ:
-c   -----------------------------------------------------------------
-
-      IF(lnblnk(gfichier).LT.1.OR.lnblnk(gfichier).GE.100) THEN
-         gfichier(1:5)='champ'
-         IF(indexfil.LT.1) indexfil=49
-         gfichier(6:6)=char(indexfil)
-	 indexfil=indexfil+1
-	 PRINT*,'nom du fichier  ',gfichier
-      ENDIF
-
-c-----------------------------------------------------------------------
-c   ecriture sur le fichier de sorties:
-c   -----------------------------------
-
-      OPEN (unit=55, file=gfichier(1:lnblnk(gfichier)))
-      WRITE(55,'(a)') gentete(1:lnblnk(gentete))
-      WRITE(55,'(a)') gtitre(1:lnblnk(gtitre))
-      WRITE(55,'(a)') gdatedep
-      WRITE(55,'(a)') gdatefin
-      WRITE(55,'(a)') gunites(1:lnblnk(gunites))
-      WRITE(55,*) gdeltapas, gnbetats
-      WRITE(55,*) gdeltajour
-      WRITE(55,*) champ(imin),champ(imax)
-      WRITE(55,'(a)') '#'//gformat(1:lnblnk(gformat))
-      WRITE(55,*) icount
-
-      IF (check) THEN
-        WRITE(*,'('//gformat(1:lnblnk(gformat))//')') champ(1)
-      ENDIF
-
-      IF (lnblnk(gformat).LE.1.OR.lnblnk(gformat).GE.20) THEN
-         DO 2230 i=1,icount
-            WRITE(55,*) champ(i)
-2230     CONTINUE
-      ELSE
-         IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli1') THEN
-            CALL to36 (champ,icount,champ(imin),champ(imax),55, 1)
-         ELSE 
-            IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli2') THEN
-               CALL to36(champ,icount,champ(imin),champ(imax),55,2)
-            ELSE
-               IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli3') THEN
-                  CALL to36(champ,icount,champ(imin),champ(imax),55,3)
-               ELSE
-                  WRITE(55,'('//gformat(1:lnblnk(gformat))//')') 
-     &            (champ(i),i=1,icount)
-               ENDIF
-            ENDIF
-         ENDIF
-      ENDIF
-
-      CLOSE (unit=55)
-
-      gfichier=' '
-
-c-----------------------------------------------------------------------
-c   si on ecrit pas le champ (writeornot.EQ..f.):
-c   ---------------------------------------------
-
-      ELSE
-        WRITE(*,*) 'FILE    ',gfichier,'WAS NOT WRITEN'
-      ENDIF
-      
-      RETURN
-      END
-
Index: trunk/LMDZ.GENERIC/libf/dyn3d/gradsdef.h
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/gradsdef.h	(revision 987)
+++ 	(revision )
@@ -1,20 +1,0 @@
-      integer nfmx,imx,jmx,lmx,nf,nvarmx
-      parameter(nfmx=10,imx=200,jmx=150,lmx=20,nvarmx=1000)
-
-      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
-
-      integer imd(imx),jmd(jmx),lmd(lmx)
-      integer iid(imx),jid(jmx)
-      integer ifd(imx),jfd(jmx)
-      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
-
-      integer nvar(nfmx),ivar(nfmx)
-      logical firsttime(nfmx)
-
-      character*10 var(nvarmx,nfmx),fichier(nfmx)
-      character*40 title(nfmx),tvar(nvarmx,nfmx)
-
-      common/gradsdef/xd,yd,zd,dtime,
-     s   imd,jmd,lmd,iid,jid,ifd,jfd,
-     s   unit,irec,nvar,ivar,nf,itime,nld,firsttime,
-     s   var,fichier,title,tvar
Index: trunk/LMDZ.GENERIC/libf/dyn3d/inigrads.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/inigrads.F	(revision 987)
+++ 	(revision )
@@ -1,77 +1,0 @@
-      subroutine inigrads(if,im
-     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
-     s  ,dt,file,titlel)
-
-
-      implicit none
-
-      integer if,im,jm,lm,i,j,l,lnblnk
-      real x(im),y(jm),z(lm),fx,fy,fz,dt
-      real xmin,xmax,ymin,ymax
-
-      character file*10,titlel*40
-
-#include "gradsdef.h"
-
-      data unit/66,32,34,36,38,40,42,44,46,48/
-      data nf/0/
-
-      if (if.le.nf) stop'verifier les appels a inigrads'
-
-      print*,'Entree dans inigrads'
-
-      nf=if
-      title(if)=titlel
-      ivar(if)=0
-
-      fichier(if)=file(1:lnblnk(file))
-
-      firsttime(if)=.true.
-      dtime(if)=dt
-
-      iid(if)=1
-      ifd(if)=im
-      imd(if)=im
-      do i=1,im
-         xd(i,if)=x(i)*fx
-         if(xd(i,if).lt.xmin) iid(if)=i+1
-         if(xd(i,if).le.xmax) ifd(if)=i
-      enddo
-      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
-
-      jid(if)=1
-      jfd(if)=jm
-      jmd(if)=jm
-      do j=1,jm
-         yd(j,if)=y(j)*fy
-         if(yd(j,if).gt.ymax) jid(if)=j+1
-         if(yd(j,if).ge.ymin) jfd(if)=j
-      enddo
-      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
-
-      print*,'Open de dat'
-      print*,'file=',file
-      print*,'fichier(if)=',fichier(if)
-
-      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
-      print*,file(1:lnblnk(file))//'.dat'
-
-      OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat',
-     s   FORM='UNFORMATTED',
-     s   ACCESS='DIRECT'
-     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
-
-      print*,'Open de dat ok'
-
-      lmd(if)=lm
-      do l=1,lm
-         zd(l,if)=z(l)*fz
-      enddo
-
-      irec(if)=0
-
-      print*,if,imd(if),jmd(if),lmd(if)
-      print*,'if,imd(if),jmd(if),lmd(if)'
-
-      return
-      end
Index: trunk/LMDZ.GENERIC/libf/dyn3d/lect_start_archive.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/lect_start_archive.F	(revision 987)
+++ 	(revision )
@@ -1,1367 +1,0 @@
-      SUBROUTINE lect_start_archive(date,tsurf,tsoil,emis,q2,
-     &     t,ucov,vcov,ps,h,phisold_newgrid,
-     &     q,qsurf,surfith,nid)
-
-      USE surfdat_h
-      USE comsoil_h
-      USE tracer_h
-
-c=======================================================================
-c
-c
-c   Auteur:    05/1997 , 12/2003 : coord hybride  FF
-c   ------
-c
-c
-c   Objet:     Lecture des variables d'un fichier "start_archive"
-c              Plus besoin de régler ancienne valeurs grace
-c              a l'allocation dynamique de memoire (Yann Wanherdrick)
-c
-c
-c
-c=======================================================================
-
-      implicit none
-
-#include "dimensions.h"
-#include "dimphys.h"
-#include "planete.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "control.h"
-#include "logic.h"
-#include "description.h"
-#include "ener.h"
-#include "temps.h"
-#include "lmdstd.h"
-#include "netcdf.inc"
-#include"advtrac.h"
-c=======================================================================
-c   Declarations
-c=======================================================================
-
-c Old variables dimensions (from file)
-c------------------------------------
-      INTEGER   imold,jmold,lmold,nsoilold,nqold
-
-
-c Variables pour les lectures des fichiers "ini" 
-c--------------------------------------------------
-!      INTEGER sizei,
-      integer timelen,dimid
-!      INTEGER length
-!      parameter (length = 100)
-      INTEGER tab0
-      INTEGER isoil,iq,iqmax
-      CHARACTER*2   str2
-
-!      REAL dimfirst(4) ! tableau contenant les 1ers elements des dimensions
-
-!      REAL dimlast(4) ! tableau contenant les derniers elements des dimensions
-
-!      REAL dimcycl(4) ! tableau contenant les periodes des dimensions
-!      CHARACTER*120 dimsource
-!      CHARACTER*16 dimname
-!      CHARACTER*80 dimtitle
-!      CHARACTER*40 dimunits
-!      INTEGER   dimtype
-
-!      INTEGER dimord(4)  ! tableau contenant l''ordre
-!      data dimord /1,2,3,4/ ! de sortie des dimensions
-
-!      INTEGER vardim(4)
-      REAL date
-      INTEGER   memo
-!      character (len=50) :: tmpname
-
-c Variable histoire 
-c------------------
-      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
-      REAL h(iip1,jjp1,llm),ps(iip1,jjp1)
-      REAL q(iip1,jjp1,llm,nqmx),qtot(iip1,jjp1,llm)
-
-c autre variables dynamique nouvelle grille
-c------------------------------------------
-
-c!-*-
-!      integer klatdat,klongdat
-!      PARAMETER (klatdat=180,klongdat=360)
-
-c Physique sur grille scalaire 
-c----------------------------
-
-c variable physique
-c------------------
-      REAL tsurf(ngridmx) ! surface temperature
-      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
-      REAL co2ice(ngridmx) ! CO2 ice layer
-      REAL emis(ngridmx)
-      REAL q2(ngridmx,nlayermx+1),qsurf(ngridmx,nqmx)
-c     REAL phisfi(ngridmx)
-
-      INTEGER i,j,l
-      INTEGER nid,nvarid
-c     REAL year_day,periheli,aphelie,peri_day
-c     REAL obliquit,z0,emin_turb,lmixmin
-c     REAL emissiv,emisice(2),albedice(2)
-c     REAL iceradius(2) , dtemisice(2)
-
-      integer ierr
-      integer, dimension(4) :: start,count
-
-c Variable nouvelle grille naturelle au point scalaire
-c------------------------------------------------------
-      real us(iip1,jjp1,llm),vs(iip1,jjp1,llm)
-      REAL phisold_newgrid(iip1,jjp1)
-      REAL t(iip1,jjp1,llm)
-      real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx)
-      real inertiedatS(iip1,jjp1,nsoilmx)
-      real co2iceS(iip1,jjp1)
-      real emisS(iip1,jjp1)
-      REAL q2S(iip1,jjp1,llm+1),qsurfS(iip1,jjp1,nqmx)
-
-      real ptotal, co2icetotal
-
-c Var intermediaires : vent naturel, mais pas coord scalaire
-c-----------------------------------------------------------
-      real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
-
-
-c Variable de l'ancienne grille 
-c---------------------------------------------------------
-
-      real, dimension(:), allocatable :: timelist
-      real, dimension(:), allocatable :: rlonuold, rlatvold
-      real, dimension(:), allocatable :: rlonvold, rlatuold
-      real, dimension(:), allocatable :: apsold,bpsold
-      real, dimension(:), allocatable :: mlayerold
-      real, dimension(:,:,:), allocatable :: uold,vold,told,q2old
-      real, dimension(:,:,:), allocatable :: tsoilold,qsurfold
-      real, dimension(:,:,:),allocatable :: tsoiloldnew
-! tsoiloldnew: old soil values, but along new subterranean grid
-      real, dimension(:,:,:), allocatable :: inertiedatold
-! inertiedatoldnew: old inertia values, but along new subterranean grid
-      real, dimension(:,:,:), allocatable :: inertiedatoldnew
-      real, dimension(:,:), allocatable :: psold,phisold
-      real, dimension(:,:), allocatable :: co2iceold
-      real, dimension(:,:), allocatable :: tsurfold
-      real, dimension(:,:), allocatable :: emisold
-      real, dimension(:,:,:,:), allocatable :: qold
-
-      real tab_cntrl(100)
-
-      real ptotalold, co2icetotalold
-
-      logical :: olddepthdef=.false. ! flag
-! olddepthdef=.true. if soil depths are in 'old' (unspecified) format
-      logical :: depthinterpol=.false. ! flag
-! depthinterpol=.true. if interpolation will be requiered
-      logical :: therminertia_3D=.true. ! flag
-! therminertia_3D=.true. if thermal inertia is 3D and read from datafile
-c Variable intermediaires iutilise pour l'extrapolation verticale 
-c----------------------------------------------------------------
-      real, dimension(:,:,:), allocatable :: var,varp1 
-      real, dimension(:), allocatable :: oldgrid, oldval
-      real, dimension(:), allocatable :: newval
-
-      real surfith(iip1,jjp1) ! surface thermal inertia
-      ! surface thermal inertia at old horizontal grid resolution
-      real, dimension(:,:), allocatable :: surfithold 
-
-      character(len=30) :: txt ! to store some text
-
-c=======================================================================
-
-! 0. Preliminary stuff
-
-
-
-!-----------------------------------------------------------------------
-! 1. Read data dimensions (i.e. size and length)
-!-----------------------------------------------------------------------
-
-! 1.2 Read the various dimension lengths of data in file 
-
-      ierr= NF_INQ_DIMID(nid,"Time",dimid)
-      if (ierr.ne.NF_NOERR) then
-         ierr= NF_INQ_DIMID(nid,"temps",dimid)
-      endif
-      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
-
-      ierr= NF_INQ_DIMID(nid,"latitude",dimid)
-      if (ierr.ne.NF_NOERR) then
-         ierr= NF_INQ_DIMID(nid,"rlatu",dimid)
-      endif
-      ierr= NF_INQ_DIMLEN(nid,dimid,jmold)
-      jmold=jmold-1
-
-      ierr= NF_INQ_DIMID(nid,"longitude",dimid)
-      if (ierr.ne.NF_NOERR) then
-         ierr= NF_INQ_DIMID(nid,"rlonv",dimid)
-      endif
-      ierr= NF_INQ_DIMLEN(nid,dimid,imold)
-      imold=imold-1
-
-      ierr= NF_INQ_DIMID(nid,"altitude",dimid)
-      if (ierr.ne.NF_NOERR) then
-         ierr= NF_INQ_DIMID(nid,"sig_s",dimid)
-      endif
-      ierr= NF_INQ_DIMLEN(nid,dimid,lmold)
-
-      nqold=0
-      do
-         write(str2,'(i2.2)') nqold+1
-         ierr= NF_INQ_VARID(nid,'q'//str2,dimid)
-!        write(*,*) 'q'//str2
-         if (ierr.eq.NF_NOERR) then
-            nqold=nqold+1
-         else
-            exit
-         endif
-      enddo
-
-! 1.2.1 find out the # of subsurface_layers
-      nsoilold=0 !dummy initialisation
-      ierr=NF_INQ_DIMID(nid,"subsurface_layers",dimid)
-      if (ierr.eq.NF_NOERR) then
-        ierr=NF_INQ_DIMLEN(nid,dimid,nsoilold)
-	if (ierr.ne.NF_NOERR) then
-	 write(*,*)'lec_start_archive: ',
-     &              'Failed reading subsurface_layers length'
-	endif
-      else
-        write(*,*)"lec_start_archive: did not find subsurface_layers"
-      endif
-
-      if (nsoilold.eq.0) then ! 'old' archive format;
-      ! must use Tg//str2 fields to compute nsoilold
-      write(*,*)"lec_start_archive: building nsoilold from Tg fields"
-        do
-	 write(str2,'(i2.2)') nsoilold+1
-	 ierr=NF_INQ_VARID(nid,'Tg'//str2,dimid)
-	 if (ierr.eq.NF_NOERR) then
-	  nsoilold=nsoilold+1
-	 else
-	  exit
-	 endif
-	enddo
-      endif
-
-
-      if (nsoilold.ne.nsoilmx) then ! interpolation will be required
-        depthinterpol=.true.
-      endif
-
-! 1.3 Report dimensions
-      
-      write(*,*) "Start_archive dimensions:"
-      write(*,*) "longitude: ",imold
-      write(*,*) "latitude: ",jmold
-      write(*,*) "altitude: ",lmold
-      write(*,*) "tracers: ",nqold
-      write(*,*) "subsurface_layers: ",nsoilold
-      if (depthinterpol) then
-      write(*,*) " => Warning, nsoilmx= ",nsoilmx
-      write(*,*) '    which implies that you want subterranean interpola
-     &tion.'
-      write(*,*) '  Otherwise, set nsoilmx -in dimphys.h- to: ',nsoilold
-      endif
-      write(*,*) "time lenght: ",timelen
-      write(*,*) 
-
-!-----------------------------------------------------------------------
-! 2. Allocate arrays to store datasets
-!-----------------------------------------------------------------------
-
-      allocate(timelist(timelen))
-      allocate(rlonuold(imold+1), rlatvold(jmold))
-      allocate(rlonvold(imold+1), rlatuold(jmold+1))
-      allocate (apsold(lmold),bpsold(lmold))
-      allocate(uold(imold+1,jmold+1,lmold))
-      allocate(vold(imold+1,jmold+1,lmold))
-      allocate(told(imold+1,jmold+1,lmold))
-      allocate(psold(imold+1,jmold+1))
-      allocate(phisold(imold+1,jmold+1))
-      allocate(qold(imold+1,jmold+1,lmold,nqmx))
-      allocate(co2iceold(imold+1,jmold+1))
-      allocate(tsurfold(imold+1,jmold+1))
-      allocate(emisold(imold+1,jmold+1))
-      allocate(q2old(imold+1,jmold+1,lmold+1))
-!      allocate(tsoilold(imold+1,jmold+1,nsoilmx))
-      allocate(tsoilold(imold+1,jmold+1,nsoilold))
-      allocate(tsoiloldnew(imold+1,jmold+1,nsoilmx))
-      allocate(inertiedatold(imold+1,jmold+1,nsoilold)) ! soil thermal inertia
-      allocate(inertiedatoldnew(imold+1,jmold+1,nsoilmx))
-      ! surface thermal inertia at old horizontal grid resolution
-      allocate(surfithold(imold+1,jmold+1))
-      allocate(mlayerold(nsoilold))
-      allocate(qsurfold(imold+1,jmold+1,nqmx))
-
-      allocate(var (imold+1,jmold+1,llm))
-      allocate(varp1 (imold+1,jmold+1,llm+1))
-
-      write(*,*) 'q2',ngridmx,nlayermx+1
-      write(*,*) 'q2S',iip1,jjp1,llm+1
-      write(*,*) 'q2old',imold+1,jmold+1,lmold+1
-
-!-----------------------------------------------------------------------
-! 3. Read time-independent data
-!-----------------------------------------------------------------------
-
-C-----------------------------------------------------------------------
-c 3.1. Lecture du tableau des parametres du run 
-c     (pour  la lecture ulterieure de "ptotalold" et "co2icetotalold")
-c-----------------------------------------------------------------------
-c
-      ierr = NF_INQ_VARID (nid, "controle", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "Lect_start_archive: champ <controle> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echoue pour <controle>"
-         CALL abort
-      ENDIF
-c
-      tab0 = 50
-
-c-----------------------------------------------------------------------
-c 3.2 Lecture des longitudes et latitudes
-c-----------------------------------------------------------------------
-c
-      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <rlonv> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <rlonv>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <rlatu> est absent"
-         CALL abort
-      ENDIF 
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <rlatu>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <rlonu> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <rlonu>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <rlatv> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <rlatv>"
-         CALL abort
-      ENDIF
-c
-
-c-----------------------------------------------------------------------
-c 3.3. Lecture des niveaux verticaux
-c-----------------------------------------------------------------------
-c
-      ierr = NF_INQ_VARID (nid, "aps", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <aps> est absent"
-         apsold=0
-         PRINT*, "<aps> set to 0"
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apsold)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, apsold)
-#endif
-         IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "lect_start_archive: Lecture echouee pour <aps>"
-         ENDIF
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "bps", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <bps> est absent"
-         PRINT*, "It must be an old start_archive, lets look for sig_s"
-         ierr = NF_INQ_VARID (nid, "sig_s", nvarid)
-         IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "Nothing to do..."
-            CALL abort
-         ENDIF
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpsold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, bpsold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <bps>"
-         CALL abort
-      END IF
-
-c-----------------------------------------------------------------------
-c 3.4 Read Soil layers depths
-c-----------------------------------------------------------------------
-     
-      ierr=NF_INQ_VARID(nid,"soildepth",nvarid)
-      if (ierr.ne.NF_NOERR) then
-       write(*,*)'lect_start_archive: Could not find <soildepth>'
-       write(*,*)' => Assuming this is an archive in old format'
-       olddepthdef=.true.
-       depthinterpol=.true.
-       ! this is how soil depth was defined in ye old days
-	do isoil=1,nsoilold
-	  mlayerold(isoil)=sqrt(887.75/3.14)*((2.**(isoil-0.5))-1.)
-	enddo
-      else
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayerold)
-#else
-        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayerold)
-#endif
-       if (ierr .NE. NF_NOERR) then
-         PRINT*, "lect_start_archive: Failed reading <soildepth>"
-         CALL abort
-       endif
-
-      endif !of if(ierr.ne.NF_NOERR)
-
-      ! Read (or build) mlayer()
-      if (depthinterpol) then
-       ! Build (default) new soil depths (mlayer(:) is in comsoil.h),
-       ! as in soil_settings.F
-       write(*,*)' => Building default soil depths'
-       do isoil=0,nsoilmx-1
-         mlayer(isoil)=2.e-4*(2.**(isoil-0.5))
-       enddo
-       write(*,*)' => mlayer: ',mlayer
-       ! Also build (default) new soil interlayer depth layer(:)
-       do isoil=1,nsoilmx
-         layer(isoil)=sqrt(mlayer(0)*mlayer(1))*
-     &                      ((mlayer(1)/mlayer(0))**(isoil-1))
-       enddo
-       write(*,*)' =>  layer: ',layer
-      else ! read mlayer() from file
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayer)
-#else
-        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayer)
-#endif
-       if (ierr .NE. NF_NOERR) then
-         PRINT*, "lect_start_archive: Failed reading <soildepth>"
-         CALL abort
-       endif
-      endif ! of if (depthinterpol)
-
-c-----------------------------------------------------------------------
-c 3.5 Read Soil thermal inertia
-c-----------------------------------------------------------------------
-
-      ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
-      if (ierr.ne.NF_NOERR) then
-       write(*,*)'lect_start_archive: Could not find <inertiedat>'
-       write(*,*)' => Assuming this is an archive in old format'
-       therminertia_3D=.false.
-       write(*,*)' => Thermal inertia will be read from reference file'
-       volcapa=1.e6
-       write(*,*)'    and soil volumetric heat capacity is set to ',
-     &           volcapa
-      else
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,inertiedatold)
-#else
-        ierr = NF_GET_VAR_REAL(nid,nvarid,inertiedatold)
-#endif
-       if (ierr .NE. NF_NOERR) then
-         PRINT*, "lect_start_archive: Failed reading <inertiedat>"
-         CALL abort
-       endif
-      endif
-
-c-----------------------------------------------------------------------
-c 3.6 Lecture geopotentiel au sol
-c-----------------------------------------------------------------------
-c
-      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <phisinit> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, phisold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <phisinit>"
-         CALL abort
-      ENDIF
-
-C-----------------------------------------------------------------------
-c   lecture de "ptotalold" et "co2icetotalold"
-c-----------------------------------------------------------------------
-      ptotalold = tab_cntrl(tab0+49)
-      co2icetotalold = tab_cntrl(tab0+50)
- 
-c-----------------------------------------------------------------------
-c 4. Lecture du temps et choix
-c-----------------------------------------------------------------------
- 
-c  lecture du temps
-c
-      ierr = NF_INQ_DIMID (nid, "Time", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         ierr = NF_INQ_DIMID (nid, "temps", nvarid)
-         IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "lect_start_archive: Le champ <Time> est absent"
-            CALL abort
-         endif
-      ENDIF
-
-      ierr = NF_INQ_VARID (nid, "Time", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         ierr = NF_INQ_VARID (nid, "temps", nvarid)
-      endif 
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, timelist)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, timelist)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <Time>"
-         CALL abort
-      ENDIF
-c
-      write(*,*)
-      write(*,*)
-      write(*,*) 'Differentes dates des etats initiaux stockes:'
-      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
-      pi=2.*ASIN(1.)
-      do i=1,timelen
-c       call solarlong(timelist(i),sollong(i))
-c       sollong(i) = sollong(i)*180./pi
-        write(*,*) 'etat initial au jour martien' ,int(timelist(i))
-c       write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)),
-c    .    sollong(i)
-      end do
-
-   6  FORMAT(i7,i7,f9.3)
- 
-      write(*,*)
-      write(*,*) 'Choix de la date'
- 123  read(*,*,iostat=ierr) date
-      if(ierr.ne.0) goto 123
-      memo = 0
-      do i=1,timelen
-        if (date.eq.int(timelist(i))) then
-            memo = i
-        endif
-      end do
- 
-      if (memo.eq.0) then
-        write(*,*)
-        write(*,*)
-        write(*,*) 'He alors... Y sait pas lire !?!'
-        write(*,*)
-        write(*,*) 'Differentes dates des etats initiaux stockes:'
-        write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
-        do i=1,timelen
-          write(*,*) 'etat initial au jour martien' ,nint(timelist(i))
-c         write(*,6) nint(timelist(i)),nint(mod(timelist(i),669))
-        end do
-        goto 123
-      endif
-
-!-----------------------------------------------------------------------
-! 5. Read (time-dependent) data from datafile
-!-----------------------------------------------------------------------
-
-
-c-----------------------------------------------------------------------
-c 5.1 Lecture des champs 2D (co2ice, emis,ps,tsurf,Tg[10], qsurf)
-c-----------------------------------------------------------------------
- 
-      start=(/1,1,memo,0/)
-      count=(/imold+1,jmold+1,1,0/)
-       
-! CO2ice is now in qsurf(igcm_co2_ice) ...
-!      ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
-!      IF (ierr .NE. NF_NOERR) THEN
-!         PRINT*, "lect_start_archive: Le champ <co2ice> est absent"
-!         CALL abort
-!      ENDIF
-!#ifdef NC_DOUBLE
-!      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,co2iceold)
-!#else
-!      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,co2iceold)
-!#endif
-!      IF (ierr .NE. NF_NOERR) THEN
-!         PRINT*, "lect_start_archive: Lecture echouee pour <co2ice>"
-!         PRINT*, NF_STRERROR(ierr)
-!         CALL abort
-!      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "emis", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <emis> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,emisold)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,emisold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <emis>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "ps", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <ps> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,psold)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,psold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <ps>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "tsurf", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <tsurf> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,tsurfold)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,tsurfold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <tsurf>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "q2surf", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <q2surf> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <q2surf>"
-         CALL abort
-      ENDIF
-c
-      write(*,*)"lect_start_archive: rlonuold:"
-     &           ,rlonuold," rlatvold:",rlatvold
-      write(*,*)
-
-! Surface tracers:      
-      do iq=1,nqmx
-        ! initialize all surface tracers to zero
-        call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
-      enddo
-
-
-!      print*,'tnom=',tnom
-!      print*,'nid',nid
-!      print*,'nvarid',nvarid
-!      stop
-
-      DO iq=1,nqmx
-          txt=trim(tnom(iq))//"_surf"
-          if (txt.eq."h2o_vap") then
-            ! There is no surface tracer for h2o_vap;
-            ! "h2o_ice" should be loaded instead
-            txt="h2o_ice_surf"
-            write(*,*) 'lect_start_archive: loading surface tracer',
-     &                     ' h2o_ice instead of h2o_vap'
-          endif
-
-        
-        write(*,*) "lect_start_archive: loading tracer ",trim(txt)
-        ierr = NF_INQ_VARID (nid,txt,nvarid)
-        IF (ierr .NE. NF_NOERR) THEN
-          PRINT*, "lect_start_archive: ",
-     &              " Tracer <",trim(txt),"> not found"
-
-!          print*,'RDW has added hack to let me continue...'
-!          CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
-     &          qsurfold(1,1,iq))
-#else
-        ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
-     &          qsurfold(1,1,iq))
-#endif
-        IF (ierr .NE. NF_NOERR) THEN
-          PRINT*, "lect_start_archive: ",
-     &             " Failed loading <",trim(txt),">"
-          write (*,*) trim(txt),'    is set to 0'
-!          call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
-        ENDIF
-
-      ENDDO ! of DO iq=1,nqmx
-
-
-!-----------------------------------------------------------------------
-! 5.2 Read 3D subterranean fields
-!-----------------------------------------------------------------------
-
-      start=(/1,1,1,memo/)
-      count=(/imold+1,jmold+1,nsoilold,1/)
-!
-! Read soil temperatures
-!
-      if (olddepthdef) then ! tsoil stored using the 'old format'
-         start=(/1,1,memo,0/)
-         count=(/imold+1,jmold+1,1,0/) ! because the "Tg" are 2D datasets
-       do isoil=1,nsoilold
-         write(str2,'(i2.2)') isoil
-c
-         ierr = NF_INQ_VARID (nid, "Tg"//str2, nvarid)
-         IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "lect_start_archive: ",
-     &              "Field <","Tg"//str2,"> not found"
-            CALL abort
-         ENDIF
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
-     &          tsoilold(1,1,isoil))
-#else
-         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
-     &          tsoilold(1,1,isoil))
-#endif
-         IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "lect_start_archive: ",
-     &            "Failed reading <","Tg"//str2,">"
-            CALL abort
-         ENDIF
-c
-       enddo ! of do isoil=1,nsoilold
-      
-      ! reset 'start' and 'count' to "3D" behaviour
-      start=(/1,1,1,memo/)
-      count=(/imold+1,jmold+1,nsoilold,1/)
-      
-      else
-       write(*,*) "lect_start_archive: loading tsoil "
-       ierr=NF_INQ_VARID(nid,"tsoil",nvarid)
-       if (ierr.ne.NF_NOERR) then
-        write(*,*)"lect_start_archive: Cannot find <tsoil>"
-	call abort
-       else
-#ifdef NC_DOUBLE
-      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,tsoilold)
-#else
-      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,tsoilold)
-#endif
-       endif ! of if (ierr.ne.NF_NOERR)
-       
-      endif ! of if (olddepthdef)
-
-!
-! Read soil thermal inertias
-!
-!      if (.not.olddepthdef) then ! no thermal inertia data in "old" archives
-!       ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
-!       if (ierr.ne.NF_NOERR) then
-!        write(*,*)"lect_start_archive: Cannot find <inertiedat>"
-!	call abort
-!       else
-!#ifdef NC_DOUBLE
-!      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,inertiedatold)
-!#else
-!      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,inertiedatold)
-!#endif
-!       endif ! of if (ierr.ne.NF_NOERR)
-!      endif
-
-c-----------------------------------------------------------------------
-c 5.3	Lecture des champs 3D (t,u,v, q2atm,q)
-c-----------------------------------------------------------------------
-
-      start=(/1,1,1,memo/)
-      count=(/imold+1,jmold+1,lmold,1/)
-
-c
-      ierr = NF_INQ_VARID (nid,"temp", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <temp> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, count, told)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid, start, count, told)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <temp>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid,"u", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <u> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,uold)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,uold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <u>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid,"v", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <v> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,vold)
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,vold)
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <v>"
-         CALL abort
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid,"q2atm", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Le champ <q2atm> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old(1,1,2))
-#else
-      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old(1,1,2))
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "lect_start_archive: Lecture echouee pour <q2atm>"
-         CALL abort
-      ENDIF
-c
-
-! Tracers:      
-      do iq=1,nqmx
-         call initial0((jmold+1)*(imold+1)*lmold,qold(1,1,1,iq) )
-      enddo
-
-      DO iq=1,nqmx
-        txt=tnom(iq)
-        write(*,*)"lect_start_archive: loading tracer ",trim(txt)
-        ierr = NF_INQ_VARID (nid,txt,nvarid)
-        IF (ierr .NE. NF_NOERR) THEN
-            PRINT*, "lect_start_archive: ",
-     &              " Tracer <",trim(txt),"> not found"
-!            CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-        ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,qold(1,1,1,iq))
-#else
-        ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,qold(1,1,1,iq))
-#endif
-        IF (ierr .NE. NF_NOERR) THEN
-          PRINT*, "lect_start_archive: ",
-     &             "  Failed loading <",trim(txt),">"
-          write (*,*) trim(txt),'      set to 1.E-30'
-          do l=1,lmold
-            do j=1,jmold+1
-              do i=1,imold+1
-                 qold(i,j,l,iq)=1.e-30
-              end do
-            end do
-          end do
-        ENDIF
-
-      ENDDO ! of DO iq=1,nqmx
-
-
-!=======================================================================
-! 6. Interpolation from old grid to new grid
-!=======================================================================
-
-c=======================================================================
-c   INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables
-c=======================================================================
-c  Interpolation horizontale puis passage dans la grille physique pour 
-c  les variables physique 
-c  Interpolation verticale puis horizontale pour chaque variable 3D
-c=======================================================================
-
-c-----------------------------------------------------------------------
-c 6.1	Variable 2d :
-c-----------------------------------------------------------------------
-c Relief 
-      call interp_horiz (phisold,phisold_newgrid,imold,jmold,iim,jjm,1,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-
-! CO2 ice is now in qsurf(igcm_co2_ice)
-!      call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1,
-!     &                   rlonuold,rlatvold,rlonu,rlatv)
-
-c Temperature de surface
-      call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf)
-c     write(44,*) 'tsurf', tsurf
-
-c Temperature du sous-sol
-!      call interp_horiz(tsoilold,tsoils,
-!     &                  imold,jmold,iim,jjm,nsoilmx,
-!     &                   rlonuold,rlatvold,rlonu,rlatv)
-!      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil)
-c     write(45,*) 'tsoil',tsoil
-
-c Emissivite de la surface
-      call interp_horiz (emisold,emiss,imold,jmold,iim,jjm,1,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,emiss,emis)
-c     write(46,*) 'emis',emis
-c-----------------------------------------------------------------------
-c 6.1.2	Traitement special de la pression au sol :
-c-----------------------------------------------------------------------
-
-c  Extrapolation la pression dans la nouvelle grille
-      call interp_horiz(psold,ps,imold,jmold,iim,jjm,1,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-
-c-----------------------------------------------------------------------
-c	On assure la conservation de la masse de l'atmosphere + calottes
-c-----------------------------------------------------------------------
-
-      ptotal =  0.
-      DO j=1,jjp1
-         DO i=1,iim
-            ptotal=ptotal+ps(i,j)*aire(i,j)/g
-         END DO
-      END DO
-      co2icetotal = 0.
-      if (igcm_co2_ice.ne.0) then
-        ! recast surface CO2 ice on new grid
-        call interp_horiz(qsurfold(1,1,igcm_co2_ice),
-     &                  qsurfs(1,1,igcm_co2_ice),
-     &                  imold,jmold,iim,jjm,1,
-     &                  rlonuold,rlatvold,rlonu,rlatv)
-       DO j=1,jjp1
-         DO i=1,iim
-           !co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
-           co2icetotal=co2icetotal+qsurfS(i,j,igcm_co2_ice)*aire(i,j)
-         END DO
-       END DO
-      else
-        write(*,*) "Warning: No co2_ice surface tracer"
-      endif
-
-      write(*,*)
-      write(*,*)'Ancienne grille: masse de l atm :',ptotalold
-      write(*,*)'Nouvelle grille: masse de l atm :',ptotal
-      write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold 
-      write(*,*)
-      write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold
-      write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal
-      if (co2icetotalold.ne.0.) then
-      write(*,*)'Ratio new ice./old ice =',co2icetotal/co2icetotalold
-      endif
-      write(*,*)
-
-
-      DO j=1,jjp1
-         DO i=1,iip1
-            ps(i,j)=ps(i,j) * ptotalold/ptotal
-         END DO
-      END DO
-
-      if ( co2icetotalold.gt.0.) then 
-!         DO j=1,jjp1
-!            DO i=1,iip1
-!               co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal
-!            END DO
-!         END DO
-        write(*,*) "Not enforcing conservation of surface CO2 ice"
-        write(*,*) " (should be OK when CO2 ice is a tracer)"
-      end if
-
-c-----------------------------------------------------------------------
-c 6.2 Subterranean 3d variables:
-c-----------------------------------------------------------------------
-
-c-----------------------------------------------------------------------
-c 6.2.1 Thermal Inertia
-c       Note: recall that inertiedat is a common in "comsoil.h"
-c-----------------------------------------------------------------------
-
-      ! depth-wise interpolation, if required
-      if (depthinterpol.and.(.not.olddepthdef)) then
-        allocate(oldval(nsoilold))
-	allocate(newval(nsoilmx))
-        write(*,*)'lect_start_archive: WARNING: vertical interpolation o
-     &f soil thermal inertia; might be wiser to reset it.'
-        write(*,*)
-       
-        do i=1,imold+1
-         do j=1,jmold+1
-	   !copy old values
-	   oldval(1:nsoilold)=inertiedatold(i,j,1:nsoilold)
-	   !interpolate
-	   call interp_line(mlayerold,oldval,nsoilold,
-     &                     mlayer,newval,nsoilmx)
-           !copy interpolated values
-           inertiedatoldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
-	 enddo
-        enddo
-        ! cleanup
-	deallocate(oldval)
-	deallocate(newval)
-      endif !of if (depthinterpol)
-
-      if (therminertia_3D) then
-        ! We have inertiedatold
-       if((imold.ne.iim).or.(jmold.ne.jjm)) then
-       write(*,*)'lect_start_archive: WARNING: horizontal interpolation 
-     &of thermal inertia; might be better to reset it.'
-       write(*,*)
-       endif
-       
-        ! Do horizontal interpolation
-	if (depthinterpol) then
-	  call interp_horiz(inertiedatoldnew,inertiedatS,
-     &                  imold,jmold,iim,jjm,nsoilmx,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-	else
-          call interp_horiz(inertiedatold,inertiedatS,
-     &                  imold,jmold,iim,jjm,nsoilold,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-        endif ! of if (depthinterpol)
-
-      else ! no 3D thermal inertia data
-       write(*,*)'lect_start_archive: using reference surface inertia'
-        ! Use surface inertia (and extend it to all depths)
-        do i=1,nsoilmx
-         inertiedatS(1:iip1,1:jjp1,i)=surfith(1:iip1,1:jjp1)
-        enddo
-	! Build an old resolution surface thermal inertia
-	! (will be needed for tsoil interpolation)
-	call interp_horiz(surfith,surfithold,
-     &                    iim,jjm,imold,jmold,1,
-     &                    rlonu,rlatv,rlonuold,rlatvold)
-      endif
-
-
-      ! Reshape inertiedatS to scalar grid as inertiedat
-      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,
-     &                  inertiedatS,inertiedat)
-      
-c-----------------------------------------------------------------------
-c 6.2.2 Soil temperature
-c-----------------------------------------------------------------------
-!      write(*,*) 'Soil'
-
-      !print*,'Problem in lect_start_archive interpolating'
-      !print*,'to new resolution!!'
-
-      ! Recast temperatures along soil depth, if necessary
-      if (olddepthdef) then
-        allocate(oldgrid(nsoilold+1))
-        allocate(oldval(nsoilold+1))
-	allocate(newval(nsoilmx))
-        do i=1,imold+1
-	 do j=1,jmold+1
-
-            !if(i.gt.iip1 .or. j.gt.jjp1)then
-               !print*,'Problem in lect_start_archive interpolating'
-               !print*,'to new resolution!!'
-               !call abort
-            !endif
-
-	   ! copy values
-	   oldval(1)=tsurfold(i,j)
-!	   oldval(1)=tsurfS(i,j)
-	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
-	   ! build vertical coordinate
-	   oldgrid(1)=0. ! ground
-	   oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)*
-     &                (surfithold(i,j)/1.e6)
-          ! Note; at this stage, we impose volcapa=1.e6 above
-	  ! since volcapa isn't set in old soil definitions
-
-	  ! interpolate
-	  call interp_line(oldgrid,oldval,nsoilold+1,
-     &                     mlayer,newval,nsoilmx)
-	 ! copy result in tsoilold
-	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
-	 enddo
-	enddo
-        ! cleanup
-	deallocate(oldgrid)
-	deallocate(oldval)
-	deallocate(newval)
-
-      else
-       if (depthinterpol) then ! if vertical interpolation is required
-        allocate(oldgrid(nsoilold+1))
-        allocate(oldval(nsoilold+1))
-	allocate(newval(nsoilmx))
-        ! build vertical coordinate
-	oldgrid(1)=0. ! ground
-	oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)
-        do i=1,imold+1
-	 do j=1,jmold+1
-	   ! copy values
-	   oldval(1)=tsurfold(i,j)
-!	   oldval(1)=tsurfS(i,j)
-	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
-	  ! interpolate
-	  call interp_line(oldgrid,oldval,nsoilold+1,
-     &                     mlayer,newval,nsoilmx)
-	 ! copy result in tsoilold
-	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
-	 enddo
-	enddo
-!	write(*,*)'tsoiloldnew(1,1,1):',tsoiloldnew(1,1,1)
-        ! cleanup
-	deallocate(oldgrid)
-	deallocate(oldval)
-	deallocate(newval)
-       
-       else
-        tsoiloldnew(:,:,:)=tsoilold(:,:,:)
-       endif ! of if (depthinterpol)
-      endif ! of if (olddepthdef)
-
-      ! Do the horizontal interpolation
-       call interp_horiz(tsoiloldnew,tsoilS,
-     &                  imold,jmold,iim,jjm,nsoilmx,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-
-      ! Reshape tsoilS to scalar grid as tsoil
-       call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoilS,tsoil)
-
-
-
-c-----------------------------------------------------------------------
-c 6.3 Variable 3d :
-c-----------------------------------------------------------------------
-      
-c temperatures atmospheriques
-      write (*,*) 'lect_start_archive: told ', told (1,jmold+1,1)  ! INFO
-      call interp_vert
-     &    (told,var,lmold,llm,apsold,bpsold,aps,bps,
-     &     psold,(imold+1)*(jmold+1))
-      write (*,*) 'lect_start_archive: var ', var (1,jmold+1,1)  ! INFO
-      call interp_horiz(var,t,imold,jmold,iim,jjm,llm,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      write (*,*) 'lect_start_archive: t ', t(1,jjp1,1)  ! INFO
-
-c q2 : pbl wind variance
-      write (*,*) 'lect_start_archive: q2old ', q2old (1,2,1)  ! INFO
-      call interp_vert (q2old,varp1,lmold+1,llm+1,
-     &     apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
-      write (*,*) 'lect_start_archive: varp1 ', varp1 (1,2,1)  ! INFO
-      call interp_horiz(varp1,q2s,imold,jmold,iim,jjm,llm+1,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      write (*,*) 'lect_start_archive: q2s ', q2s (1,2,1)  ! INFO
-      call gr_dyn_fi (llm+1,iim+1,jjm+1,ngridmx,q2s,q2)
-      write (*,*) 'lect_start_archive: q2 ', q2 (1,2)  ! INFO
-c     write(47,*) 'q2',q2
-
-c calcul des champ de vent; passage en vent covariant
-      write (*,*) 'lect_start_archive: uold ', uold (1,2,1)  ! INFO
-      call interp_vert
-     & (uold,var,lmold,llm,apsold,bpsold,aps,bps,
-     &  psold,(imold+1)*(jmold+1))
-      write (*,*) 'lect_start_archive: var ', var (1,2,1)  ! INFO
-      call interp_horiz(var,us,imold,jmold,iim,jjm,llm,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      write (*,*) 'lect_start_archive: us ', us (1,2,1)   ! INFO
-
-      call interp_vert
-     & (vold,var,lmold,llm,
-     &  apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
-      call interp_horiz(var,vs,imold,jmold,iim,jjm,llm,
-     &                   rlonuold,rlatvold,rlonu,rlatv)
-      call scal_wind(us,vs,unat,vnat)
-      write (*,*) 'lect_start_archive: unat ', unat (1,2,1)    ! INFO
-      do l=1,llm
-        do j = 1, jjp1
-          do i=1,iip1
-            ucov( i,j,l ) = unat( i,j,l ) * cu(i,j)
-c           ucov( i,j,l ) = 0
-          end do
-        end do
-      end do 
-      write (*,*) 'lect_start_archive: ucov ', ucov (1,2,1)  ! INFO
-c     write(48,*) 'ucov',ucov
-      do l=1,llm
-        do j = 1, jjm
-          do i=1,iim
-            vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j)
-c           vcov( i,j,l ) = 0
-          end do
-          vcov( iip1,j,l ) = vcov( 1,j,l )
-        end do
-      end do
-c     write(49,*) 'ucov',vcov
-
-      if (nqmx .gt. 0) then
-c traceurs surface
-      do iq = 1, nqmx
-            call interp_horiz(qsurfold(1,1,iq) ,qsurfs(1,1,iq),
-     &                  imold,jmold,iim,jjm,1,
-     &                  rlonuold,rlatvold,rlonu,rlatv)
-      enddo
-
-      call gr_dyn_fi (nqmx,iim+1,jjm+1,ngridmx,qsurfs,qsurf)
-
-c traceurs 3D
-      do  iq = 1, nqmx
-            call interp_vert(qold(1,1,1,iq),var,lmold,llm,
-     &        apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
-            call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm,
-     &                  rlonuold,rlatvold,rlonu,rlatv)
-      enddo
-cccccccccccccccccccccccccccccc      
-c  make sure that sum of q = 1      
-c dominent species is = 1 - sum(all other species)      
-cccccccccccccccccccccccccccccc      
-c      iqmax=1
-c      
-c      if (nqold.gt.10) then
-c       do l=1,llm
-c        do j=1,jjp1
-c          do i=1,iip1
-c           do iq=1,nqold
-c            if (q(i,j,l,iq).gt.q(i,j,l,iqmax)) then
-c              iqmax=iq
-c            endif
-c           enddo
-c           q(i,j,l,iqmax)=1.
-c           qtot(i,j,l)=0
-c           do iq=1,nqold
-c            if (iq.ne.iqmax) then        
-c              q(i,j,l,iqmax)=q(i,j,l,iqmax)-q(i,j,l,iq)        
-c            endif
-c           enddo !iq
-c           do iq=1,nqold
-c            qtot(i,j,l)=qtot(i,j,l)+q(i,j,l,iq)
-c            if (i.eq.1.and.j.eq.1.and.l.Eq.1) write(*,*)' qtot(i,j,l)',
-c     $    qtot(i,j,l)
-c           enddo !iq
-c          enddo !i   
-c         enddo !j   
-c       enddo !l  
-c      endif
-ccccccccccccccccccccccccccccccc
-
-c     Periodicite :
-      do  iq = 1, nqmx
-         do l=1, llm
-            do j = 1, jjp1
-               q(iip1,j,l,iq) = q(1,j,l,iq)
-            end do
-         end do
-      enddo
-      
-!      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice)
-! no need to transfer "co2ice" any more; it is in qsurf(igcm_co2_ice)
-
-      endif !! if nqmx .ne. 0
-
-c-----------------------------------------------------------------------
-c   Initialisation  h:	(passage de t -> h)
-c-----------------------------------------------------------------------
-
-      DO l=1,llm
-         DO j=1,jjp1
-            DO i=1,iim
-               h(i,j,l) = t(i,j,l)*((ps(i,j)/preff)**kappa)
-            END DO
-            h(iip1,j,l) =  h(1,j,l)
-         END DO
-      END DO
-
-
-c***********************************************************************
-c***********************************************************************
-c     Fin subroutine lecture ini
-c***********************************************************************
-c***********************************************************************
-
-      deallocate(timelist)
-      deallocate(rlonuold, rlatvold)
-      deallocate(rlonvold, rlatuold)
-      deallocate(apsold,bpsold)
-      deallocate(uold)
-      deallocate(vold)
-      deallocate(told)
-      deallocate(psold)
-      deallocate(phisold)
-      deallocate(qold)
-      deallocate(co2iceold)
-      deallocate(tsurfold)
-      deallocate(emisold)
-      deallocate(q2old)
-      deallocate(tsoilold)
-      deallocate(tsoiloldnew)
-      deallocate(inertiedatold)
-      deallocate(inertiedatoldnew)
-      deallocate(surfithold)
-      deallocate(mlayerold)
-      deallocate(qsurfold)
-      deallocate(var,varp1)
-
-!      write(*,*)'lect_start_archive: END'
-      return
-      end
Index: trunk/LMDZ.GENERIC/libf/dyn3d/newstart.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/newstart.F	(revision 987)
+++ 	(revision )
@@ -1,1463 +1,0 @@
-C======================================================================
-      PROGRAM newstart
-c=======================================================================
-c
-c
-c   Auteur:   Christophe Hourdin/Francois Forget/Yann Wanherdrick
-c   ------
-c             Derniere modif : 12/03
-c
-c
-c   Objet:  Create or modify the initial state for the LMD Mars GCM
-c   -----           (fichiers NetCDF start et startfi)
-c
-c
-c=======================================================================
-
-      USE tracer_h
-      USE comsoil_h
-      USE surfdat_h
-      USE comgeomfi_h
-
-      implicit none
-
-#include "dimensions.h"
-#include "dimphys.h"
-#include "planete.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "control.h"
-#include "logic.h"
-#include "description.h"
-#include "ener.h"
-#include "temps.h"
-#include "lmdstd.h"
-#include "comdissnew.h"
-#include "clesph0.h"
-#include "serre.h"
-#include "netcdf.inc"
-#include "advtrac.h"
-c=======================================================================
-c   Declarations
-c=======================================================================
-
-c Variables dimension du fichier "start_archive"
-c------------------------------------
-      CHARACTER	relief*3
-
-
-c Variables pour les lectures NetCDF des fichiers "start_archive" 
-c--------------------------------------------------
-      INTEGER nid_dyn, nid_fi,nid,nvarid
-      INTEGER length
-      parameter (length = 100)
-      INTEGER tab0
-      INTEGER   NB_ETATMAX
-      parameter (NB_ETATMAX = 100)
-
-      REAL  date
-      REAL p_rad,p_omeg,p_g,p_cpp,p_mugaz,p_daysec
-
-c Variable histoire 
-c------------------
-      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
-      REAL phis(iip1,jjp1)
-      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
-
-c autre variables dynamique nouvelle grille
-c------------------------------------------
-      REAL pks(iip1,jjp1)
-      REAL w(iip1,jjp1,llm+1)
-      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
-!      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
-!      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
-      REAL phi(iip1,jjp1,llm)
-
-      integer klatdat,klongdat
-      PARAMETER (klatdat=180,klongdat=360)
-
-c Physique sur grille scalaire 
-c----------------------------
-      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
-      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
-
-c variable physique
-c------------------
-      REAL tsurf(ngridmx)	! surface temperature
-      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
-!      REAL co2ice(ngridmx)	! CO2 ice layer
-      REAL emis(ngridmx)	! surface emissivity
-      real emisread             ! added by RW
-      REAL qsurf(ngridmx,nqmx)
-      REAL q2(ngridmx,nlayermx+1)
-!      REAL rnaturfi(ngridmx)
-      real alb(iip1,jjp1),albfi(ngridmx) ! albedos
-      real ith(iip1,jjp1,nsoilmx),ithfi(ngridmx,nsoilmx) ! thermal inertia (3D)
-      real surfith(iip1,jjp1),surfithfi(ngridmx) ! surface thermal inertia (2D)
-      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
-
-      INTEGER i,j,l,isoil,ig,idum
-      real mugaz ! molar mass of the atmosphere
-
-      integer ierr 
-
-c Variables on the new grid along scalar points 
-c------------------------------------------------------
-!      REAL p(iip1,jjp1)
-      REAL t(iip1,jjp1,llm)
-      REAL tset(iip1,jjp1,llm)
-      real phisold_newgrid(iip1,jjp1)
-      REAL :: teta(iip1, jjp1, llm)
-      REAL :: pk(iip1,jjp1,llm)
-      REAL :: pkf(iip1,jjp1,llm)
-      REAL :: ps(iip1, jjp1)
-      REAL :: masse(iip1,jjp1,llm)
-      REAL :: xpn,xps,xppn(iim),xpps(iim)
-      REAL :: p3d(iip1, jjp1, llm+1)
-      REAL :: beta(iip1,jjp1,llm)
-!      REAL dteta(ip1jmp1,llm)
-
-c Variable de l'ancienne grille 
-c------------------------------
-      real time
-      real tab_cntrl(100)
-      real tab_cntrl_bis(100)
-
-c variables diverses
-c-------------------
-      real choix_1,pp
-      character*80      fichnom
-      integer Lmodif,iq,thermo
-      character modif*20
-      real z_reel(iip1,jjp1)
-      real tsud,albsud,alb_bb,ith_bb,Tiso,Tabove
-      real ptoto,pcap,patm,airetot,ptotn,patmn,psea
-!      real ssum
-      character*1 yes
-      logical :: flagtset=.false. ,  flagps0=.false.
-      real val, val2, val3 ! to store temporary variables
-      real :: iceith=2000 ! thermal inertia of subterranean ice
-      integer iref,jref
-
-      INTEGER :: itau
-      
-      INTEGER :: nq,numvanle
-      character(len=20) :: txt ! to store some text
-      integer :: count
-      real :: profile(llm+1) ! to store an atmospheric profile + surface value
-
-!     added by RW for test
-      real pmean, phi0
-
-!     added by BC for equilibrium temperature startup
-      real teque
-
-!     added by BC for cloud fraction setup
-      REAL hice(ngridmx),cloudfrac(ngridmx,nlayermx)
-      REAL totalfrac(ngridmx)
-
-!     added by RW for nuketharsis
-      real fact1
-      real fact2
-
-
-c sortie visu pour les champs dynamiques
-c---------------------------------------
-!      INTEGER :: visuid
-!      real :: time_step,t_ops,t_wrt
-!      CHARACTER*80 :: visu_file
-
-      cpp    = 0.
-      preff  = 0.
-      pa     = 0. ! to ensure disaster rather than minor error if we don`t
-                  ! make deliberate choice of these values elsewhere.
-
-c=======================================================================
-c   Choice of the start file(s) to use
-c=======================================================================
-
-      write(*,*) 'From which kind of files do you want to create new',
-     .  'start and startfi files'
-      write(*,*) '    0 - from a file start_archive'
-      write(*,*) '    1 - from files start and startfi'
- 
-c-----------------------------------------------------------------------
-c   Open file(s) to modify (start or start_archive)
-c-----------------------------------------------------------------------
-
-      DO
-         read(*,*,iostat=ierr) choix_1
-         if ((choix_1 /= 0).OR.(choix_1 /=1)) EXIT
-      ENDDO
-
-c     Open start_archive
-c     ~~~~~~~~~~~~~~~~~~~~~~~~~~
-      if (choix_1.eq.0) then
-
-        write(*,*) 'Creating start files from:'
-        write(*,*) './start_archive.nc'
-        write(*,*)
-        fichnom = 'start_archive.nc'
-        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
-        IF (ierr.NE.NF_NOERR) THEN
-          write(6,*)' Problem opening file:',fichnom
-          write(6,*)' ierr = ', ierr
-          CALL ABORT
-        ENDIF
-        tab0 = 50 
-        Lmodif = 1
-
-c     OR open start and startfi files
-c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-      else
-        write(*,*) 'Creating start files from:'
-        write(*,*) './start.nc and ./startfi.nc'
-        write(*,*)
-        fichnom = 'start.nc'
-        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_dyn)
-        IF (ierr.NE.NF_NOERR) THEN
-          write(6,*)' Problem opening file:',fichnom
-          write(6,*)' ierr = ', ierr
-          CALL ABORT
-        ENDIF
- 
-        fichnom = 'startfi.nc'
-        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_fi)
-        IF (ierr.NE.NF_NOERR) THEN
-          write(6,*)' Problem opening file:',fichnom
-          write(6,*)' ierr = ', ierr
-          CALL ABORT
-        ENDIF
-
-        tab0 = 0 
-        Lmodif = 0
-
-      endif
-
-
-c=======================================================================
-c  INITIALISATIONS DIVERSES
-c=======================================================================
-! Load tracer names:
-      call iniadvtrac(nq,numvanle)
-      ! tnom(:) now contains tracer names
-! JL12 we will need the tracer names to read start in dyneta0
-
-! Initialize global tracer indexes (stored in tracer.h)
-! ... this has to be done before phyetat0
-      call initracer(ngridmx,nqmx,tnom)
-
-! Take care of arrays in common modules
-      ! ALLOCATE ARRAYS in surfdat_h (if not already done, e.g. when using start_archive)
-      IF (.not. ALLOCATED(albedodat)) ALLOCATE(albedodat(ngridmx))
-      IF (.not. ALLOCATED(phisfi)) ALLOCATE(phisfi(ngridmx))
-      IF (.not. ALLOCATED(zmea)) ALLOCATE(zmea(ngridmx))
-      IF (.not. ALLOCATED(zstd)) ALLOCATE(zstd(ngridmx))
-      IF (.not. ALLOCATED(zsig)) ALLOCATE(zsig(ngridmx))
-      IF (.not. ALLOCATED(zgam)) ALLOCATE(zgam(ngridmx))
-      IF (.not. ALLOCATED(zthe)) ALLOCATE(zthe(ngridmx))
-      ! ALLOCATE ARRAYS in comsoil_h (if not already done)
-      IF (.not.ALLOCATED(layer))
-     . ALLOCATE(layer(nsoilmx))
-      IF (.not.ALLOCATED(mlayer))
-     . ALLOCATE(mlayer(0:nsoilmx-1))
-      IF (.not.ALLOCATED(inertiedat))
-     . ALLOCATE(inertiedat(ngridmx,nsoilmx))
-      ! ALLOCATE ARRAYS IN comgeomfi_h (done in inifis usually)
-      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(ngridmx))
-      IF (.not. ALLOCATED(long)) ALLOCATE(long(ngridmx))
-      IF (.not. ALLOCATED(area)) ALLOCATE(area(ngridmx))
-      cursor = 1 ! added by AS in dimphys. 1 for sequential runs.
-
-c-----------------------------------------------------------------------
-c Lecture du tableau des parametres du run (pour la dynamique)
-c-----------------------------------------------------------------------
-
-      if (choix_1.eq.0) then
-
-        write(*,*) 'reading tab_cntrl START_ARCHIVE'
-c
-        ierr = NF_INQ_VARID (nid, "controle", nvarid)
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
-#else
-        ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
-#endif
-c
-      else if (choix_1.eq.1) then
-
-        write(*,*) 'reading tab_cntrl START'
-c
-        ierr = NF_INQ_VARID (nid_dyn, "controle", nvarid)
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid_dyn, nvarid, tab_cntrl)
-#else
-        ierr = NF_GET_VAR_REAL(nid_dyn, nvarid, tab_cntrl)
-#endif
-c
-        write(*,*) 'reading tab_cntrl STARTFI'
-c
-        ierr = NF_INQ_VARID (nid_fi, "controle", nvarid)
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid_fi, nvarid, tab_cntrl_bis)
-#else
-        ierr = NF_GET_VAR_REAL(nid_fi, nvarid, tab_cntrl_bis)
-#endif
-c
-        do i=1,50
-          tab_cntrl(i+50)=tab_cntrl_bis(i)
-        enddo
-        write(*,*) 'printing tab_cntrl', tab_cntrl
-        do i=1,100
-          write(*,*) i,tab_cntrl(i)
-        enddo
-	
-        ! Lmodif set to 0 to disable modifications possibility in phyeta0                           
-        write(*,*) 'Reading file START'
-        fichnom = 'start.nc'
-        CALL dynetat0(fichnom,nqmx,vcov,ucov,teta,q,masse,
-     .       ps,phis,time)
-
-        write(*,*) 'Reading file STARTFI'
-        fichnom = 'startfi.nc'
-        CALL phyetat0 (ngridmx,fichnom,tab0,Lmodif,nsoilmx,nqmx,
-     .        day_ini,time,
-     .        tsurf,tsoil,emis,q2,qsurf,   !) ! temporary modif by RDW
-     .        cloudfrac,totalfrac,hice)
-
-        ! copy albedo and soil thermal inertia on (local) physics grid
-        do i=1,ngridmx
-          albfi(i) = albedodat(i)
-	  do j=1,nsoilmx
-           ithfi(i,j) = inertiedat(i,j)
-	  enddo
-        ! build a surfithfi(:) using 1st layer of ithfi(:), which might
-        ! be needed later on if reinitializing soil thermal inertia
-          surfithfi(i)=ithfi(i,1)
-        enddo
-        ! also copy albedo and soil thermal inertia on (local) dynamics grid
-        ! so that options below can manipulate either (but must then ensure
-        ! to correctly recast things on physics grid)
-        call gr_fi_dyn(1,ngridmx,iip1,jjp1,albfi,alb)
-        call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
-        call gr_fi_dyn(1,ngridmx,iip1,jjp1,surfithfi,surfith)
-      
-      endif
-c-----------------------------------------------------------------------
-c		Initialisation des constantes dynamique
-c-----------------------------------------------------------------------
-
-      kappa = tab_cntrl(9) 
-      etot0 = tab_cntrl(12)
-      ptot0 = tab_cntrl(13)
-      ztot0 = tab_cntrl(14)
-      stot0 = tab_cntrl(15)
-      ang0 = tab_cntrl(16)
-      write(*,*) "Newstart: kappa,etot0,ptot0,ztot0,stot0,ang0"
-      write(*,*) kappa,etot0,ptot0,ztot0,stot0,ang0
-
-      ! for vertical coordinate
-      preff=tab_cntrl(18) ! reference surface pressure
-      pa=tab_cntrl(17)  ! reference pressure at which coord is purely pressure
-      !NB: in start_archive files tab_cntrl(17)=tab_cntrl(18)=0
-      write(*,*) "Newstart: preff=",preff," pa=",pa
-      yes=' '
-      do while ((yes.ne.'y').and.(yes.ne.'n'))
-        write(*,*) "Change the values of preff and pa? (y/n)"
-        read(*,fmt='(a)') yes
-      end do
-      if (yes.eq.'y') then
-        write(*,*)"New value of reference surface pressure preff?"
-        write(*,*)"   (for Mars, typically preff=610)"
-        read(*,*) preff
-        write(*,*)"New value of reference pressure pa for purely"
-        write(*,*)"pressure levels (for hybrid coordinates)?"
-        write(*,*)"   (for Mars, typically pa=20)"
-        read(*,*) pa
-      endif
-c-----------------------------------------------------------------------
-c   Lecture du tab_cntrl et initialisation des constantes physiques
-c  - pour start:  Lmodif = 0 => pas de modifications possibles
-c                  (modif dans le tabfi de readfi + loin)
-c  - pour start_archive:  Lmodif = 1 => modifications possibles
-c-----------------------------------------------------------------------
-      if (choix_1.eq.0) then
-         call tabfi (ngridmx,nid,Lmodif,tab0,day_ini,lllm,p_rad,
-     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
-      else if (choix_1.eq.1) then
-         Lmodif=1 ! Lmodif set to 1 to allow modifications in phyeta0                           
-         call tabfi (ngridmx,nid_fi,Lmodif,tab0,day_ini,lllm,p_rad,
-     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
-      endif
-
-      rad = p_rad
-      omeg = p_omeg
-      g = p_g
-      cpp = p_cpp
-      mugaz = p_mugaz
-      daysec = p_daysec
-
-      kappa = 8.314*1000./(p_mugaz*p_cpp) ! added by RDW
-
-c=======================================================================
-c  INITIALISATIONS DIVERSES
-c=======================================================================
-! Load parameters from run.def file
-      CALL defrun_new( 99, .TRUE. )
-      CALL iniconst 
-      CALL inigeom
-      idum=-1
-      idum=0
-
-c Initialisation coordonnees /aires
-c -------------------------------
-! Note: rlatu(:) and rlonv(:) are commons defined in "comgeom.h"
-!       rlatu() and rlonv() are given in radians
-      latfi(1)=rlatu(1)
-      lonfi(1)=0.
-      DO j=2,jjm
-         DO i=1,iim
-            latfi((j-2)*iim+1+i)=rlatu(j)
-            lonfi((j-2)*iim+1+i)=rlonv(i)
-         ENDDO
-      ENDDO
-      latfi(ngridmx)=rlatu(jjp1)
-      lonfi(ngridmx)=0.
-       
-      ! build airefi(), mesh area on physics grid
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
-      ! Poles are single points on physics grid
-      airefi(1)=airefi(1)*iim
-      airefi(ngridmx)=airefi(ngridmx)*iim
-
-c=======================================================================
-c   lecture topographie, albedo, inertie thermique, relief sous-maille
-c=======================================================================
-
-      if (choix_1.ne.1) then  ! pour ne pas avoir besoin du fichier 
-                              ! surface.dat dans le cas des start
-
-c do while((relief(1:3).ne.'mol').AND.(relief(1:3).ne.'pla'))
-c       write(*,*)
-c       write(*,*) 'choix du relief (mola,pla)'
-c       write(*,*) '(Topographie MGS MOLA, plat)'
-c       read(*,fmt='(a3)') relief
-        relief="mola"
-c     enddo
-
-      CALL datareadnc(relief,phis,alb,surfith,zmeaS,zstdS,zsigS,zgamS,
-     .          ztheS)
-
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,surfith,surfithfi)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zmeaS,zmea)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zstdS,zstd)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zsigS,zsig)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zgamS,zgam)
-      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ztheS,zthe)
-
-      endif ! of if (choix_1.ne.1)
-
-
-c=======================================================================
-c  Lecture des fichiers (start ou start_archive)
-c=======================================================================
-
-      if (choix_1.eq.0) then
-
-        write(*,*) 'Reading file START_ARCHIVE'
-        CALL lect_start_archive(date,tsurf,tsoil,emis,q2,
-     .   t,ucov,vcov,ps,teta,phisold_newgrid,q,qsurf,
-     &   surfith,nid)
-        write(*,*) "OK, read start_archive file"
-	! copy soil thermal inertia
-	ithfi(:,:)=inertiedat(:,:)
-	
-        ierr= NF_CLOSE(nid)
-
-      else if (choix_1.eq.1) then 
-         !do nothing, start and startfi have already been read
-      else 
-        CALL exit(1)
-      endif
-
-      dtvr   = daysec/FLOAT(day_step)
-      dtphys   = dtvr * FLOAT(iphysiq)
-
-c=======================================================================
-c 
-c=======================================================================
-
-      do ! infinite loop on list of changes
-
-      write(*,*)
-      write(*,*)
-      write(*,*) 'List of possible changes :'
-      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
-      write(*,*)
-      write(*,*) 'flat : no topography ("aquaplanet")'
-      write(*,*) 'nuketharsis : no Tharsis bulge'
-      write(*,*) 'bilball : uniform albedo and thermal inertia'
-      write(*,*) 'coldspole : cold subsurface and high albedo at S.pole'
-      write(*,*) 'qname : change tracer name'
-      write(*,*) 'q=0 : ALL tracer =zero'
-      write(*,*) 'q=x : give a specific uniform value to one tracer'
-      write(*,*) 'q=profile    : specify a profile for a tracer'
-!      write(*,*) 'ini_q : tracers initialisation for chemistry, water an
-!     $d ice   '
-!      write(*,*) 'ini_q-H2O : tracers initialisation for chemistry and 
-!     $ice '
-!      write(*,*) 'ini_q-iceH2O : tracers initialisation for chemistry on
-!     $ly '
-      write(*,*) 'noglacier : Remove tropical H2O ice if |lat|<45'
-      write(*,*) 'watercapn : H20 ice on permanent N polar cap '
-      write(*,*) 'watercaps : H20 ice on permanent S polar cap '
-      write(*,*) 'noacglac  : H2O ice across Noachis Terra'
-      write(*,*) 'oborealis : H2O ice across Vastitas Borealis'
-      write(*,*) 'iceball   : Thick ice layer all over surface'
-      write(*,*) 'wetstart  : start with a wet atmosphere'
-      write(*,*) 'isotherm  : Isothermal Temperatures, wind set to zero'
-      write(*,*) 'radequi   : Earth-like radiative equilibrium temperature
-     $ profile (lat-alt) and winds set to zero'
-      write(*,*) 'coldstart : Start X K above the CO2 frost point and 
-     $set wind to zero (assumes 100% CO2)'
-      write(*,*) 'co2ice=0 : remove CO2 polar cap'
-      write(*,*) 'ptot : change total pressure'
-      write(*,*) 'emis : change surface emissivity'
-      write(*,*) 'therm_ini_s : Set soil thermal inertia to reference sur
-     &face values'
-
-        write(*,*)
-        write(*,*) 'Change to perform ?'
-        write(*,*) '   (enter keyword or return to end)'
-        write(*,*)
-
-        read(*,fmt='(a20)') modif
-        if (modif(1:1) .eq. ' ') exit ! exit loop on changes
-
-        write(*,*)
-        write(*,*) trim(modif) , ' : '
-
-c       'flat : no topography ("aquaplanet")'
-c       -------------------------------------
-        if (trim(modif) .eq. 'flat') then
-c         set topo to zero 
-          z_reel(1:iip1,1:jjp1)=0
-          phis(1:iip1,1:jjp1)=g*z_reel(1:iip1,1:jjp1)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-          write(*,*) 'topography set to zero.'
-          write(*,*) 'WARNING : the subgrid topography parameters',
-     &    ' were not set to zero ! => set calllott to F'                    
-
-c        Choice of surface pressure
-         yes=' '
-         do while ((yes.ne.'y').and.(yes.ne.'n'))
-            write(*,*) 'Do you wish to choose homogeneous surface',
-     &                 'pressure (y) or let newstart interpolate ',
-     &                 ' the previous field  (n)?'
-             read(*,fmt='(a)') yes
-         end do
-         if (yes.eq.'y') then
-           flagps0=.true.
-           write(*,*) 'New value for ps (Pa) ?'
- 201       read(*,*,iostat=ierr) patm
-            if(ierr.ne.0) goto 201
-             write(*,*)
-             write(*,*) ' new ps everywhere (Pa) = ', patm
-             write(*,*)
-             do j=1,jjp1
-               do i=1,iip1
-                 ps(i,j)=patm
-               enddo
-             enddo
-         end if
-
-c       'nuketharsis : no tharsis bulge for Early Mars'
-c       ---------------------------------------------
-        else if (trim(modif) .eq. 'nuketharsis') then
-
-           DO j=1,jjp1        
-              DO i=1,iim
-                 ig=1+(j-2)*iim +i
-                 if(j.eq.1) ig=1
-                 if(j.eq.jjp1) ig=ngridmx
-
-                 fact1=(((rlonv(i)*180./pi)+100)**2 + 
-     &                (rlatu(j)*180./pi)**2)/65**2 
-                 fact2=exp( -fact1**2.5 )
-
-                 phis(i,j) = phis(i,j) - (phis(i,j)+4000.*g)*fact2
-
-!                 if(phis(i,j).gt.2500.*g)then
-!                    if(rlatu(j)*180./pi.gt.-80.)then ! avoid chopping south polar cap
-!                       phis(i,j)=2500.*g
-!                    endif
-!                 endif
-
-              ENDDO
-           ENDDO
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-
-
-c       bilball : uniform albedo, thermal inertia
-c       -----------------------------------------
-        else if (trim(modif) .eq. 'bilball') then
-          write(*,*) 'constante albedo and iner.therm:'
-          write(*,*) 'New value for albedo (ex: 0.25) ?'
- 101      read(*,*,iostat=ierr) alb_bb
-          if(ierr.ne.0) goto 101
-          write(*,*)
-          write(*,*) ' uniform albedo (new value):',alb_bb
-          write(*,*)
-
-          write(*,*) 'New value for thermal inertia (eg: 247) ?'
- 102      read(*,*,iostat=ierr) ith_bb
-          if(ierr.ne.0) goto 102
-          write(*,*) 'uniform thermal inertia (new value):',ith_bb
-          DO j=1,jjp1
-             DO i=1,iip1
-                alb(i,j) = alb_bb	! albedo
-		do isoil=1,nsoilmx
-                  ith(i,j,isoil) = ith_bb	! thermal inertia
-		enddo
-             END DO
-          END DO
-!          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-
-c       coldspole : sous-sol de la calotte sud toujours froid
-c       -----------------------------------------------------
-        else if (trim(modif) .eq. 'coldspole') then
-          write(*,*)'new value for the subsurface temperature',
-     &   ' beneath the permanent southern polar cap ? (eg: 141 K)'
- 103      read(*,*,iostat=ierr) tsud
-          if(ierr.ne.0) goto 103
-          write(*,*)
-          write(*,*) ' new value of the subsurface temperature:',tsud
-c         nouvelle temperature sous la calotte permanente
-          do l=2,nsoilmx
-               tsoil(ngridmx,l) =  tsud
-          end do
-
-
-          write(*,*)'new value for the albedo',
-     &   'of the permanent southern polar cap ? (eg: 0.75)'
- 104      read(*,*,iostat=ierr) albsud
-          if(ierr.ne.0) goto 104
-          write(*,*)
-
-c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c         Option 1:  only the albedo of the pole is modified :    
-          albfi(ngridmx)=albsud
-          write(*,*) 'ig=',ngridmx,'   albedo perennial cap ',
-     &    albfi(ngridmx)
-
-c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
-c          Option 2 A haute resolution : coordonnee de la vrai calotte ~    
-c           DO j=1,jjp1
-c             DO i=1,iip1
-c                ig=1+(j-2)*iim +i
-c                if(j.eq.1) ig=1
-c                if(j.eq.jjp1) ig=ngridmx
-c                if ((rlatu(j)*180./pi.lt.-84.).and.
-c     &            (rlatu(j)*180./pi.gt.-91.).and.
-c     &            (rlonv(i)*180./pi.gt.-91.).and.
-c     &            (rlonv(i)*180./pi.lt.0.))         then
-cc    albedo de la calotte permanente fixe a albsud
-c                   alb(i,j)=albsud
-c                   write(*,*) 'lat=',rlatu(j)*180./pi,
-c     &                      ' lon=',rlonv(i)*180./pi
-cc     fin de la condition sur les limites de la calotte permanente
-c                end if
-c             ENDDO
-c          ENDDO
-c      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-c         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-
-
-c       ptot : Modification of the total pressure: ice + current atmosphere 
-c       -------------------------------------------------------------------
-        else if (trim(modif).eq.'ptot') then
-
-          ! check if we have a co2_ice surface tracer:
-          if (igcm_co2_ice.eq.0) then
-            write(*,*) " No surface CO2 ice !"
-            write(*,*) " only atmospheric pressure will be considered!"
-          endif
-c         calcul de la pression totale glace + atm actuelle
-          patm=0.
-          airetot=0.
-          pcap=0.
-          DO j=1,jjp1
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-                patm = patm + ps(i,j)*aire(i,j)
-                airetot= airetot + aire(i,j)
-                if (igcm_co2_ice.ne.0) then
-                  !pcap = pcap + aire(i,j)*co2ice(ig)*g
-                  pcap = pcap + aire(i,j)*qsurf(ig,igcm_co2_ice)*g
-                endif
-             ENDDO
-          ENDDO
-          ptoto = pcap + patm
-
-          print*,'Current total pressure at surface (co2 ice + atm) ',
-     &       ptoto/airetot
-
-          print*,'new value?'
-          read(*,*) ptotn
-          ptotn=ptotn*airetot
-          patmn=ptotn-pcap
-          print*,'ptoto,patm,ptotn,patmn'
-          print*,ptoto,patm,ptotn,patmn
-          print*,'Mult. factor for pressure (atm only)', patmn/patm
-          do j=1,jjp1
-             do i=1,iip1
-                ps(i,j)=ps(i,j)*patmn/patm
-             enddo
-          enddo
-
-
-
-c        Correction pour la conservation des traceurs
-         yes=' '
-         do while ((yes.ne.'y').and.(yes.ne.'n'))
-            write(*,*) 'Do you wish to conserve tracer total mass (y)',
-     &              ' or tracer mixing ratio (n) ?'
-             read(*,fmt='(a)') yes
-         end do
-
-         if (yes.eq.'y') then
-           write(*,*) 'OK : conservation of tracer total mass'
-           DO iq =1, nqmx
-             DO l=1,llm
-               DO j=1,jjp1
-                  DO i=1,iip1
-                    q(i,j,l,iq)=q(i,j,l,iq)*patm/patmn
-                  ENDDO
-               ENDDO
-             ENDDO
-           ENDDO
-          else
-            write(*,*) 'OK : conservation of tracer mixing ratio'
-          end if
-
-c        Correction pour la pression au niveau de la mer
-         yes=' '
-         do while ((yes.ne.'y').and.(yes.ne.'n'))
-            write(*,*) 'Do you wish fix pressure at sea level (y)',
-     &              ' or not (n) ?'
-             read(*,fmt='(a)') yes
-         end do
-
-         if (yes.eq.'y') then
-           write(*,*) 'Value?'
-		read(*,*,iostat=ierr) psea
-             DO i=1,iip1
-               DO j=1,jjp1
-                    ps(i,j)=psea
-
-                  ENDDO
-               ENDDO
-		write(*,*) 'psea=',psea
-          else
-            write(*,*) 'no'
-          end if
-
-
-c       emis : change surface emissivity (added by RW)
-c       ----------------------------------------------
-        else if (trim(modif).eq.'emis') then
-
-           print*,'new value?'
-           read(*,*) emisread
-
-           do i=1,ngridmx
-              emis(i)=emisread
-           enddo
-
-c       qname : change tracer name
-c       --------------------------
-        else if (trim(modif).eq.'qname') then
-         yes='y'
-         do while (yes.eq.'y')
-          write(*,*) 'Which tracer name do you want to change ?'
-          do iq=1,nqmx
-            write(*,'(i3,a3,a20)')iq,' : ',trim(tnom(iq))
-          enddo
-          write(*,'(a35,i3)')
-     &            '(enter tracer number; between 1 and ',nqmx
-          write(*,*)' or any other value to quit this option)'
-          read(*,*) iq
-          if ((iq.ge.1).and.(iq.le.nqmx)) then
-            write(*,*)'Change tracer name ',trim(tnom(iq)),' to ?'
-            read(*,*) txt
-            tnom(iq)=txt
-            write(*,*)'Do you want to change another tracer name (y/n)?'
-            read(*,'(a)') yes 
-          else
-! inapropiate value of iq; quit this option
-            yes='n'
-          endif ! of if ((iq.ge.1).and.(iq.le.nqmx))
-         enddo ! of do while (yes.ne.'y')
-
-c       q=0 : set tracers to zero
-c       -------------------------
-        else if (trim(modif).eq.'q=0') then
-c          mise a 0 des q (traceurs)
-          write(*,*) 'Tracers set to 0 (1.E-30 in fact)'
-           DO iq =1, nqmx
-             DO l=1,llm
-               DO j=1,jjp1
-                  DO i=1,iip1
-                    q(i,j,l,iq)=1.e-30
-                  ENDDO
-               ENDDO
-             ENDDO
-           ENDDO
-
-c          set surface tracers to zero
-           DO iq =1, nqmx
-             DO ig=1,ngridmx
-                 qsurf(ig,iq)=0.
-             ENDDO
-           ENDDO
-
-c       q=x : initialise tracer manually 
-c       --------------------------------
-        else if (trim(modif).eq.'q=x') then
-             write(*,*) 'Which tracer do you want to modify ?'
-             do iq=1,nqmx
-               write(*,*)iq,' : ',trim(tnom(iq))
-             enddo
-             write(*,*) '(choose between 1 and ',nqmx,')'
-             read(*,*) iq 
-             write(*,*)'mixing ratio of tracer ',trim(tnom(iq)),
-     &                 ' ? (kg/kg)'
-             read(*,*) val
-             DO l=1,llm
-               DO j=1,jjp1
-                  DO i=1,iip1
-                    q(i,j,l,iq)=val
-                  ENDDO
-               ENDDO
-             ENDDO
-             write(*,*) 'SURFACE value of tracer ',trim(tnom(iq)),
-     &                   ' ? (kg/m2)'
-             read(*,*) val
-             DO ig=1,ngridmx
-                 qsurf(ig,iq)=val
-             ENDDO
-
-c       q=profile : initialize tracer with a given profile
-c       --------------------------------------------------
-        else if (trim(modif) .eq. 'q=profile') then
-             write(*,*) 'Tracer profile will be sought in ASCII file'
-             write(*,*) "'profile_tracer' where 'tracer' is tracer name"
-             write(*,*) "(one value per line in file; starting with"
-             write(*,*) "surface value, the 1st atmospheric layer"
-             write(*,*) "followed by 2nd, etc. up to top of atmosphere)"
-             write(*,*) 'Which tracer do you want to set?'
-             do iq=1,nqmx
-               write(*,*)iq,' : ',trim(tnom(iq))
-             enddo
-             write(*,*) '(choose between 1 and ',nqmx,')'
-             read(*,*) iq 
-             if ((iq.lt.1).or.(iq.gt.nqmx)) then
-               ! wrong value for iq, go back to menu
-               write(*,*) "wrong input value:",iq
-               cycle
-             endif
-             ! look for input file 'profile_tracer'
-             txt="profile_"//trim(tnom(iq))
-             open(41,file=trim(txt),status='old',form='formatted',
-     &            iostat=ierr)
-             if (ierr.eq.0) then
-               ! OK, found file 'profile_...', load the profile
-               do l=1,llm+1
-                 read(41,*,iostat=ierr) profile(l)
-                 if (ierr.ne.0) then ! something went wrong
-                   exit ! quit loop
-                 endif
-               enddo
-               if (ierr.eq.0) then
-                 ! initialize tracer values
-                 qsurf(:,iq)=profile(1)
-                 do l=1,llm
-                   q(:,:,l,iq)=profile(l+1)
-                 enddo
-                 write(*,*)'OK, tracer ',trim(tnom(iq)),' initialized ',
-     &                     'using values from file ',trim(txt)
-               else
-                 write(*,*)'problem reading file ',trim(txt),' !'
-                 write(*,*)'No modifications to tracer ',trim(tnom(iq))
-               endif
-             else
-               write(*,*)'Could not find file ',trim(txt),' !'
-               write(*,*)'No modifications to tracer ',trim(tnom(iq))
-             endif
-             
-
-c      wetstart : wet atmosphere with a north to south gradient
-c      --------------------------------------------------------
-       else if (trim(modif) .eq. 'wetstart') then
-        ! check that there is indeed a water vapor tracer
-        if (igcm_h2o_vap.eq.0) then
-          write(*,*) "No water vapour tracer! Can't use this option"
-          stop
-        endif
-          DO l=1,llm
-            DO j=1,jjp1
-              DO i=1,iip1
-                q(i,j,l,igcm_h2o_vap)=150.e-6 * (rlatu(j)+pi/2.) / pi
-              ENDDO
-            ENDDO
-          ENDDO
-
-         write(*,*) 'Water mass mixing ratio at north pole='
-     *               ,q(1,1,1,igcm_h2o_vap)
-         write(*,*) '---------------------------south pole='
-     *               ,q(1,jjp1,1,igcm_h2o_vap)
-
-c      noglacier : remove tropical water ice (to initialize high res sim)
-c      --------------------------------------------------
-        else if (trim(modif) .eq. 'noglacier') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-           do ig=1,ngridmx
-             j=(ig-2)/iim +2
-              if(ig.eq.1) j=1
-              write(*,*) 'OK: remove surface ice for |lat|<45'
-              if (abs(rlatu(j)*180./pi).lt.45.) then
-                   qsurf(ig,igcm_h2o_ice)=0.
-              end if
-           end do
-
-
-c      watercapn : H20 ice on permanent northern cap
-c      --------------------------------------------------
-        else if (trim(modif) .eq. 'watercapn') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-
-           DO j=1,jjp1        
-              DO i=1,iim
-                 ig=1+(j-2)*iim +i
-                 if(j.eq.1) ig=1
-                 if(j.eq.jjp1) ig=ngridmx
-
-                 if (rlatu(j)*180./pi.gt.80.) then
-                    qsurf(ig,igcm_h2o_ice)=3.4e3
-                    !do isoil=1,nsoilmx
-                    !   ith(i,j,isoil) = 18000. ! thermal inertia
-                    !enddo
-                   write(*,*)'     ==> Ice mesh North boundary (deg)= ',
-     &                   rlatv(j-1)*180./pi
-                 end if
-              ENDDO
-           ENDDO
-           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-
-c$$$           do ig=1,ngridmx
-c$$$             j=(ig-2)/iim +2
-c$$$              if(ig.eq.1) j=1
-c$$$              if (rlatu(j)*180./pi.gt.80.) then
-c$$$
-c$$$                   qsurf(ig,igcm_h2o_ice)=1.e5
-c$$$                   qsurf(ig,igcm_h2o_vap)=0.0!1.e5
-c$$$
-c$$$                   write(*,*) 'ig=',ig,'    H2O ice mass (kg/m2)= ',
-c$$$     &              qsurf(ig,igcm_h2o_ice)
-c$$$
-c$$$                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
-c$$$     &              rlatv(j)*180./pi
-c$$$                end if
-c$$$           enddo
-
-c      watercaps : H20 ice on permanent southern cap
-c      -------------------------------------------------
-        else if (trim(modif) .eq. 'watercaps') then
-           if (igcm_h2o_ice.eq.0) then
-              write(*,*) "No water ice tracer! Can't use this option"
-              stop
-           endif
-
-           DO j=1,jjp1        
-              DO i=1,iim
-                 ig=1+(j-2)*iim +i
-                 if(j.eq.1) ig=1
-                 if(j.eq.jjp1) ig=ngridmx
-
-                 if (rlatu(j)*180./pi.lt.-80.) then
-                    qsurf(ig,igcm_h2o_ice)=3.4e3
-                    !do isoil=1,nsoilmx
-                    !   ith(i,j,isoil) = 18000. ! thermal inertia
-                    !enddo
-                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
-     &                   rlatv(j-1)*180./pi
-                 end if
-              ENDDO
-           ENDDO
-           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-
-c$$$           do ig=1,ngridmx
-c$$$               j=(ig-2)/iim +2
-c$$$               if(ig.eq.1) j=1
-c$$$               if (rlatu(j)*180./pi.lt.-80.) then
-c$$$                  qsurf(ig,igcm_h2o_ice)=1.e5
-c$$$                  qsurf(ig,igcm_h2o_vap)=0.0 !1.e5
-c$$$
-c$$$                  write(*,*) 'ig=',ig,'   H2O ice mass (kg/m2)= ',
-c$$$     &                 qsurf(ig,igcm_h2o_ice)
-c$$$                  write(*,*)'     ==> Ice mesh North boundary (deg)= ',
-c$$$     &                 rlatv(j-1)*180./pi
-c$$$               end if
-c$$$           enddo
-
-
-c       noacglac : H2O ice across highest terrain
-c       --------------------------------------------
-        else if (trim(modif) .eq. 'noacglac') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-          DO j=1,jjp1        
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-
-                if(phis(i,j).gt.1000.*g)then
-                    alb(i,j) = 0.5 ! snow value
-                    do isoil=1,nsoilmx
-                       ith(i,j,isoil) = 18000. ! thermal inertia
-                       ! this leads to rnat set to 'ocean' in physiq.F90
-                       ! actually no, because it is soil not surface
-                    enddo
-                endif
-             ENDDO
-          ENDDO
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-
-
-
-c       oborealis : H2O oceans across Vastitas Borealis
-c       -----------------------------------------------
-        else if (trim(modif) .eq. 'oborealis') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-          DO j=1,jjp1        
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-
-                if(phis(i,j).lt.-4000.*g)then
-!                if( (phis(i,j).lt.-4000.*g)
-!     &               .and. (rlatu(j)*180./pi.lt.0.) )then ! south hemisphere only
-!                    phis(i,j)=-8000.0*g ! proper ocean
-                    phis(i,j)=-4000.0*g ! scanty ocean
-
-                    alb(i,j) = 0.07 ! oceanic value
-                    do isoil=1,nsoilmx
-                       ith(i,j,isoil) = 18000. ! thermal inertia
-                       ! this leads to rnat set to 'ocean' in physiq.F90
-                       ! actually no, because it is soil not surface
-                    enddo
-                endif
-             ENDDO
-          ENDDO
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-
-c       iborealis : H2O ice in Northern plains
-c       --------------------------------------
-        else if (trim(modif) .eq. 'iborealis') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-          DO j=1,jjp1        
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-
-                if(phis(i,j).lt.-4000.*g)then
-                   !qsurf(ig,igcm_h2o_ice)=1.e3
-                   qsurf(ig,igcm_h2o_ice)=241.4 ! to make total 33 kg m^-2
-                endif
-             ENDDO
-          ENDDO
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-
-
-c       oceanball : H2O liquid everywhere
-c       ----------------------------
-        else if (trim(modif) .eq. 'oceanball') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-          DO j=1,jjp1        
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-
-                qsurf(ig,igcm_h2o_vap)=0.0    ! for ocean, this is infinite source
-                qsurf(ig,igcm_h2o_ice)=0.0
-                alb(i,j) = 0.07 ! ocean value
-
-                do isoil=1,nsoilmx
-                   ith(i,j,isoil) = 18000. ! thermal inertia
-                   !ith(i,j,isoil) = 50. ! extremely low for test
-                   ! this leads to rnat set to 'ocean' in physiq.F90
-                enddo
-
-             ENDDO
-          ENDDO
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
-
-c       iceball : H2O ice everywhere
-c       ----------------------------
-        else if (trim(modif) .eq. 'iceball') then
-           if (igcm_h2o_ice.eq.0) then
-             write(*,*) "No water ice tracer! Can't use this option"
-             stop
-           endif
-          DO j=1,jjp1        
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-
-                qsurf(ig,igcm_h2o_vap)=-50.    ! for ocean, this is infinite source
-                qsurf(ig,igcm_h2o_ice)=50.     ! == to 0.05 m of oceanic ice
-                alb(i,j) = 0.6 ! ice albedo value
-
-                do isoil=1,nsoilmx
-                   !ith(i,j,isoil) = 18000. ! thermal inertia
-                   ! this leads to rnat set to 'ocean' in physiq.F90
-                enddo
-
-             ENDDO
-          ENDDO
-          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
-          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
-
-c       isotherm : Isothermal temperatures and no winds
-c       -----------------------------------------------
-        else if (trim(modif) .eq. 'isotherm') then
-
-          write(*,*)'Isothermal temperature of the atmosphere, 
-     &           surface and subsurface'
-          write(*,*) 'Value of this temperature ? :'
- 203      read(*,*,iostat=ierr) Tiso
-          if(ierr.ne.0) goto 203
-
-          tsurf(1:ngridmx)=Tiso
-          
-          tsoil(1:ngridmx,1:nsoilmx)=Tiso
-          
-          Tset(1:iip1,1:jjp1,1:llm)=Tiso
-          flagtset=.true.
-          
-          ucov(1:iip1,1:jjp1,1:llm)=0
-          vcov(1:iip1,1:jjm,1:llm)=0
-          q2(1:ngridmx,1:nlayermx+1)=0
-
-c       radequi : Radiative equilibrium profile of temperatures and no winds
-c       --------------------------------------------------------------------
-        else if (trim(modif) .eq. 'radequi') then
-
-          write(*,*)'radiative equilibrium temperature profile'       
-
-          do ig=1, ngridmx
-             teque= 335.0-60.0*sin(latfi(ig))*sin(latfi(ig))-
-     &            10.0*cos(latfi(ig))*cos(latfi(ig))
-             tsurf(ig) = MAX(220.0,teque)
-          end do
-          do l=2,nsoilmx
-             do ig=1, ngridmx
-                tsoil(ig,l) = tsurf(ig)
-             end do
-          end do
-          DO j=1,jjp1
-             DO i=1,iim
-                Do l=1,llm
-                   teque=335.-60.0*sin(rlatu(j))*sin(rlatu(j))-
-     &                  10.0*cos(rlatu(j))*cos(rlatu(j))
-                   Tset(i,j,l)=MAX(220.0,teque)
-                end do
-             end do
-          end do
-          flagtset=.true.
-          ucov(1:iip1,1:jjp1,1:llm)=0
-          vcov(1:iip1,1:jjm,1:llm)=0
-          q2(1:ngridmx,1:nlayermx+1)=0
-
-c       coldstart : T set 1K above CO2 frost point and no winds
-c       ------------------------------------------------
-        else if (trim(modif) .eq. 'coldstart') then
-
-          write(*,*)'set temperature of the atmosphere,' 
-     &,'surface and subsurface how many degrees above CO2 frost point?'
- 204      read(*,*,iostat=ierr) Tabove
-          if(ierr.ne.0) goto 204
-
-            DO j=1,jjp1
-             DO i=1,iim
-                ig=1+(j-2)*iim +i
-                if(j.eq.1) ig=1
-                if(j.eq.jjp1) ig=ngridmx
-            tsurf(ig) = (-3167.8)/(log(.01*ps(i,j))-23.23)+Tabove
-             END DO
-            END DO
-          do l=1,nsoilmx
-            do ig=1, ngridmx
-              tsoil(ig,l) = tsurf(ig)
-            end do
-          end do
-          DO j=1,jjp1
-           DO i=1,iim
-            Do l=1,llm
-               pp = aps(l) +bps(l)*ps(i,j) 
-               Tset(i,j,l)=(-3167.8)/(log(.01*pp)-23.23)+Tabove
-            end do
-           end do
-          end do
-
-          flagtset=.true.
-          ucov(1:iip1,1:jjp1,1:llm)=0
-          vcov(1:iip1,1:jjm,1:llm)=0
-          q2(1:ngridmx,1:nlayermx+1)=0
-
-
-c       co2ice=0 : remove CO2 polar ice caps'
-c       ------------------------------------------------
-        else if (trim(modif) .eq. 'co2ice=0') then
-         ! check that there is indeed a co2_ice tracer ...
-          if (igcm_co2_ice.ne.0) then
-           do ig=1,ngridmx
-              !co2ice(ig)=0
-              qsurf(ig,igcm_co2_ice)=0
-              emis(ig)=emis(ngridmx/2)
-           end do
-          else
-            write(*,*) "Can't remove CO2 ice!! (no co2_ice tracer)"
-          endif
-        
-!       therm_ini_s: (re)-set soil thermal inertia to reference surface values
-!       ----------------------------------------------------------------------
-
-	else if (trim(modif).eq.'therm_ini_s') then
-!          write(*,*)"surfithfi(1):",surfithfi(1)
-	  do isoil=1,nsoilmx
-	    inertiedat(1:ngridmx,isoil)=surfithfi(1:ngridmx)
-	  enddo
-          write(*,*)'OK: Soil thermal inertia has been reset to referenc
-     &e surface values'
-!	  write(*,*)"inertiedat(1,1):",inertiedat(1,1)
-	  ithfi(:,:)=inertiedat(:,:)
-	 ! recast ithfi() onto ith()
-	 call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
-! Check:
-!         do i=1,iip1
-!           do j=1,jjp1
-!             do isoil=1,nsoilmx
-!               write(77,*) i,j,isoil,"  ",ith(i,j,isoil)
-!             enddo
-!           enddo
-!	 enddo
-
-
-        else
-          write(*,*) '       Unknown (misspelled?) option!!!'
-        end if ! of if (trim(modif) .eq. '...') elseif ...
-	
-
-
-
-
-
-
-
-
-
-
-       enddo ! of do ! infinite loop on liste of changes
-
- 999  continue
-
- 
-c=======================================================================
-c   Initialisation for cloud fraction and oceanic ice (added by BC 2010)
-c=======================================================================
-      DO ig=1, ngridmx
-         totalfrac(ig)=0.5
-         DO l=1,llm
-            cloudfrac(ig,l)=0.5
-         ENDDO
-! Ehouarn, march 2012: also add some initialisation for hice
-         hice(ig)=0.0
-      ENDDO
-      
-c========================================================
-
-!      DO ig=1,ngridmx
-!         IF(tsurf(ig) .LT. 273.16-1.8) THEN
-!            hice(ig)=(273.16-1.8-tsurf(ig))/(273.16-1.8-240)*1.
-!            hice(ig)=min(hice(ig),1.0)
-!         ENDIF
-!      ENDDO
-
-c=======================================================================
-c   Correct pressure on the new grid (menu 0)
-c=======================================================================
-
-
-      if ((choix_1.eq.0).and.(.not.flagps0)) then
-        r = 1000.*8.31/mugaz
-
-        do j=1,jjp1
-          do i=1,iip1
-             ps(i,j) = ps(i,j) *
-     .            exp((phisold_newgrid(i,j)-phis(i,j)) /
-     .                                  (t(i,j,1) * r))
-          end do
-        end do
-
-c periodicite de ps en longitude
-        do j=1,jjp1
-          ps(1,j) = ps(iip1,j)
-        end do
-      end if
-
-         
-c=======================================================================
-c=======================================================================
-
-c=======================================================================
-c    Initialisation de la physique / ecriture de newstartfi :
-c=======================================================================
-
-
-      CALL inifilr 
-      CALL pression(ip1jmp1, ap, bp, ps, p3d)
-
-c-----------------------------------------------------------------------
-c   Initialisation  pks:
-c-----------------------------------------------------------------------
-
-      CALL exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
-! Calcul de la temperature potentielle teta
-
-      if (flagtset) then
-          DO l=1,llm
-             DO j=1,jjp1
-                DO i=1,iim
-                   teta(i,j,l) = Tset(i,j,l) * cpp/pk(i,j,l)
-                ENDDO
-                teta (iip1,j,l)= teta (1,j,l)
-             ENDDO
-          ENDDO
-      else if (choix_1.eq.0) then
-         DO l=1,llm
-            DO j=1,jjp1
-               DO i=1,iim
-                  teta(i,j,l) = t(i,j,l) * cpp/pk(i,j,l)
-               ENDDO
-               teta (iip1,j,l)= teta (1,j,l)
-            ENDDO
-         ENDDO
-      endif
-
-C Calcul intermediaire
-c
-      if (choix_1.eq.0) then
-         CALL massdair( p3d, masse  )
-c
-         print *,' ALPHAX ',alphax
-
-         DO  l = 1, llm
-           DO  i    = 1, iim
-             xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
-             xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
-           ENDDO
-             xpn      = SUM(xppn)/apoln
-             xps      = SUM(xpps)/apols
-           DO i   = 1, iip1
-             masse(   i   ,   1     ,  l )   = xpn
-             masse(   i   ,   jjp1  ,  l )   = xps
-           ENDDO
-         ENDDO
-      endif
-      phis(iip1,:) = phis(1,:)
-
-      CALL inidissip ( lstardis, nitergdiv, nitergrot, niterh,
-     *                tetagdiv, tetagrot , tetatemp  )
-      itau=0
-      if (choix_1.eq.0) then
-         day_ini=int(date)
-      endif
-c
-      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
-
-      CALL caldyn0( itau,ucov,vcov,teta,ps,masse,pk,phis ,
-     *                phi,w, pbaru,pbarv,day_ini+time )
-
-          
-      CALL dynredem0("restart.nc",day_ini,anneeref,phis,nqmx)
-      CALL dynredem1("restart.nc",0.0,vcov,ucov,teta,q,nqmx,masse,ps) 
-C
-C Ecriture etat initial physique
-C
-
-!      do ig=1,ngridmx
-!         print*,'surface ice in newstart=',qsurf(ig,igcm_h2o_ice)
-!         print*,'surface liq in newstart=',qsurf(ig,igcm_h2o_vap)
-!      enddo
-!      stop
-
-
-      call physdem1(ngridmx,"restartfi.nc",lonfi,latfi,nsoilmx,nqmx,
-     .              dtphys,float(day_ini),
-     .              time,tsurf,tsoil,emis,q2,qsurf,
-     .              airefi,albfi,ithfi,zmea,zstd,zsig,zgam,zthe,
-     .              cloudfrac,totalfrac,hice,tnom)
-
-c=======================================================================
-c	Formats 
-c=======================================================================
-
-   1  FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dema
-     *rrage est differente de la valeur parametree iim =',i4//)
-   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dema
-     *rrage est differente de la valeur parametree jjm =',i4//)
-   3  FORMAT(//10x,'la valeur de lllm =',i4,2x,'lue sur le fichier demar
-     *rage est differente de la valeur parametree llm =',i4//)
-
-      end
-
Index: trunk/LMDZ.GENERIC/libf/dyn3d/wrgrads.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/wrgrads.F	(revision 987)
+++ 	(revision )
@@ -1,125 +1,0 @@
-      subroutine wrgrads(if,nl,field,name,titlevar)
-      implicit none
-
-c   Declarations
-c    if indice du fichier
-c    nl nombre de couches
-c    field   champ
-c    name    petit nom
-c    titlevar   Titre
-
-#include "gradsdef.h"
-
-c   arguments
-      integer if,nl
-      real field(imx*jmx*lmx)
-      character*10 name,file
-      character*10 titlevar
-
-c   local
-
-      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
-
-      logical writectl
-
-
-      writectl=.false.
-
-c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
-      iii=iid(if)
-      iji=jid(if)
-      iif=ifd(if)
-      ijf=jfd(if)
-      im=iif-iii+1
-      jm=ijf-iji+1
-      lm=lmd(if)
-
-c      print*,'im,jm,lm,name,firsttime(if)'
-c      print*,im,jm,lm,name,firsttime(if)
-
-      if(firsttime(if)) then
-         if(name.eq.var(1,if)) then
-            firsttime(if)=.false.
-            ivar(if)=1
-         print*,'fin de l initialiation de l ecriture du fichier'
-         print*,file
-           print*,'fichier no: ',if
-           print*,'unit ',unit(if)
-           print*,'nvar  ',nvar(if)
-           print*,'vars ',(var(iv,if),iv=1,nvar(if))
-         else
-            ivar(if)=ivar(if)+1
-            nvar(if)=ivar(if)
-            var(ivar(if),if)=name
-            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
-            nld(ivar(if),if)=nl
-            print*,'initialisation ecriture de ',var(ivar(if),if)
-            print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
-         endif
-         writectl=.true.
-         itime(if)=1
-      else
-         ivar(if)=mod(ivar(if),nvar(if))+1
-         if (ivar(if).eq.nvar(if)) then
-            writectl=.true.
-            itime(if)=itime(if)+1
-         endif
-
-         if(var(ivar(if),if).ne.name) then
-           print*,'Il faut stoker la meme succession de champs a chaque'
-           print*,'pas de temps'
-           print*,'fichier no: ',if
-           print*,'unit ',unit(if)
-           print*,'nvar  ',nvar(if)
-           print*,'vars ',(var(iv,if),iv=1,nvar(if))
-
-           stop
-         endif
-      endif
-
-c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
-c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
-      do l=1,nl
-         irec(if)=irec(if)+1
-c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
-c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
-c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
-         write(unit(if)+1,rec=irec(if))
-     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
-     s   ,i=iii,iif),j=iji,ijf)
-      enddo
-      if (writectl) then
-
-      file=fichier(if)
-c   WARNING! on reecrase le fichier .ctl a chaque ecriture
-      open(unit(if),file=file(1:lnblnk(file))//'.ctl',
-     &         form='formatted',status='unknown')
-      write(unit(if),'(a5,1x,a40)')
-     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
-
-      write(unit(if),'(a12)') 'UNDEF 1.0E30'
-      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
-      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
-      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
-      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
-      write(unit(if),'(a4,i10,a30)')
-     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
-      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
-      do iv=1,nvar(if)
-c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
-c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
-         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
-     &     ,99,tvar(iv,if)
-      enddo
-      write(unit(if),'(a7)') 'ENDVARS'
-c
-1000  format(a5,3x,i4,i3,1x,a39)
-
-      close(unit(if))
-
-      endif ! writectl
-
-      return
-
-      END
-
Index: trunk/LMDZ.GENERIC/libf/dyn3d/xvik.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/dyn3d/xvik.F	(revision 987)
+++ 	(revision )
@@ -1,546 +1,0 @@
-      PROGRAM xvik
-      IMPLICIT NONE
-c=======================================================================
-c
-c  Pression au site Viking
-c
-c=======================================================================
-c-----------------------------------------------------------------------
-c   declarations:
-c   -------------
-
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comdissip.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "logic.h"
-#include "temps.h"
-#include "control.h"
-#include "ener.h"
-#include "description.h"
-#include "netcdf.inc"      
-
-
-      INTEGER itau,nbpas,nbpasmx
-      PARAMETER(nbpasmx=1000000)
-      REAL temps(nbpasmx)
-      INTEGER unitlec
-      INTEGER i,j,l,jj
-      REAL constR
-
-c   Declarations NCDF:
-c   -----------------
-      CHARACTER*100  varname
-      INTEGER ierr,nid,nvarid,dimid
-      LOGICAL nc
-      INTEGER start_ps(3),start_temp(4),start_co2ice(3)
-      INTEGER count_ps(3),count_temp(4),count_co2ice(3)
-
-c   declarations pour les points viking:
-c   ------------------------------------
-      INTEGER ivik(2),jvik(2),ifile(2),iv
-      REAL lonvik(2),latvik(2),phivik(2),phisim(2)
-      REAL unanj
-
-c   variables meteo:
-c   ----------------
-      REAL vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
-      REAL t(iip1,jjp1,llm),ps(iip1,jjp1),pstot, phis(iip1,jjp1)
-      REAL co2ice(iip1,jjp1), captotN,captotS
-      real t7(iip1,jjp1) ! temperature in 7th atmospheric layer
-
-      REAL zp1,zp2,zp2_sm,zu,zv,zw(0:1,0:1,2),zalpha,zbeta
-
-      LOGICAL firstcal,lcal,latcal,lvent,day_ls
-      INTEGER*4 day0
-
-      REAL ziceco2(iip1,jjp1)
-      REAL day,zt,sollong,sol,dayw
-      REAL airtot1,gh
-
-      INTEGER ii,iyear,kyear
-
-      CHARACTER*2 chr2
-
-       
-c   declarations de l'interface avec mywrite:
-c   -----------------------------------------
-
-      CHARACTER file*80
-      CHARACTER pathchmp*80,pathsor*80,nomfich*80
-
-c   externe:
-c   --------
-
-      EXTERNAL iniconst,inigeom,covcont,mywrite
-      EXTERNAL inifilr,exner,pbar
-      EXTERNAL solarlong,coordij,moy2
-      EXTERNAL SSUM
-      REAL SSUM
-      EXTERNAL lnblnk
-      INTEGER lnblnk
-
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-c-----------------------------------------------------------------------
-c   initialisations:
-c   ----------------
-
-      unanj=667.9
-      print*,'WARNING!!!',unanj,'Jours/an'
-      nc=.true.
-      lcal=.true.
-      latcal=.true.
-      lvent=.false.
-      day_ls=.true.
-
-c lecture du fichier xvik.def
-
-      phivik(1)=-3627
-      phivik(2)=-4505
-
-
-
-      OPEN(99,file='xvik.def',form='formatted')
-
-      READ(99,*) 
-      READ(99,*,iostat=ierr) phivik
-      IF(ierr.NE.0) GOTO 105
-
-      READ(99,*,END=105)
-      READ(99,'(a)',END=105) pathchmp
-      READ(99,*,END=105)
-      READ(99,'(a)',END=105) pathsor
-      READ(99,*,END=105)
-c     READ(99,'(l1)',END=105) day_ls
-      READ(99,'(l1)',END=105)
-      READ(99,'(l1)',END=105) lcal
-      READ(99,'(l1)',END=105)
-      READ(99,'(l1)',END=105) lvent
-      READ(99,'(l1)',END=105)
-      READ(99,'(l1)',END=105) latcal
- 
- 105  CONTINUE
-      CLOSE(99)
-      write (*,*)'>>>>>>>>>>>>>>>>', phivik,g
-      DO iv=1,2
-         phivik(iv)=phivik(iv)*3.73
-      END DO
-
-      write(*,*) ' pathchmp:',trim(pathchmp)
-      write(*,*) ' pathsor:',trim(pathsor)
-      
-c-----------------------------------------------------------------------
-c-----------------------------------------------------------------------
-c   ouverture des fichiers xgraph:
-c   ------------------------------
-
-      ifile(1)=12
-      ifile(2)=13
-      kyear=-1
-c      OPEN(77,file='xlongday',form='formatted')
-
-      unitlec=11
-c
-      PRINT*,'entrer le nom du fichier NC'
-      READ(5,'(a)') nomfich
-
-      PRINT *,'nomfich : ',nomfich
-
-
-c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-c   grande boucle sur les fichiers histoire:
-c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-      firstcal=.true.
-      DO WHILE(lnblnk(nomfich).GT.0.AND.lnblnk(nomfich).LT.50)
-      PRINT *,'>>>  nomfich : ',trim(nomfich)
-
-c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-      file=pathchmp(1:lnblnk(pathchmp))//'/'//
-     s     nomfich(1:lnblnk(nomfich))
-      PRINT*,'file.nc: ', file(1:lnblnk(file))//'.nc'
-      PRINT*,'timestep ',dtvr
-
-      IF(nc) THEN
-      ierr= NF_OPEN(file(1:lnblnk(file))//'.nc',NF_NOWRITE,nid)        
-      ELSE
-         PRINT*,'Ouverture binaire ',file
-         OPEN(unitlec,file=file,status='old',form='unformatted',
-     .   iostat=ierr)
-      ENDIF
-
-c----------------------------------------------------------------------
-c   initialisation de la physique:
-c   ------------------------------
-
-      CALL readhead_NC(file(1:lnblnk(file))//'.nc',day0,phis,constR)
-
-      WRITE (*,*) 'day0 = ' , day0
-
-      CALL iniconst
-      CALL inigeom
-      CALL inifilr
-
-
-c   Lecture temps :
-
-      ierr= NF_INQ_DIMID (nid,"Time",dimid)
-        IF (ierr.NE.NF_NOERR) THEN
-          PRINT*, 'xvik: Le champ <Time> est absent'
-          CALL abort
-        ENDIF
-
-      ierr= NF_INQ_DIMLEN (nid,dimid,nbpas)
-
-      ierr = NF_INQ_VARID (nid, "Time", nvarid)
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, temps)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, temps)
-#endif
-        IF (ierr.NE.NF_NOERR) THEN
-          PRINT*, 'xvik: Lecture echouee pour <Time>'
-          CALL abort
-        ENDIF
-
-        PRINT*,'temps',(temps(itau),itau=1,10)
-              
-c-----------------------------------------------------------------------
-c   coordonnees des point Viking:
-c   -----------------------------
-
-      latvik(1)=22.27*pi/180.
-      lonvik(1)=-47.9*pi/180.
-      latvik(2)=47.67*pi/180.
-      lonvik(2)=(360.-225.71)*pi/180.
-
-c   ponderations pour les 4 points autour de Viking
-      DO iv=1,2
-         CALL coordij(lonvik(iv),latvik(iv),ivik(iv),jvik(iv))
-         IF(lonvik(iv).lt.rlonv(ivik(iv))) THEN
-            ivik(iv)=ivik(iv)-1
-         ENDIF
-         IF(latvik(iv).gt.rlatu(jvik(iv))) THEN
-            jvik(iv)=jvik(iv)-1
-         ENDIF
-         zalpha=(lonvik(iv)-rlonv(ivik(iv)))/
-     s          (rlonv(ivik(iv)+1)-rlonv(ivik(iv)))
-         zbeta=(latvik(iv)-rlatu(jvik(iv)))/
-     s          (rlatu(jvik(iv)+1)-rlatu(jvik(iv)))
-         zw(0,0,iv)=(1.-zalpha)*(1.-zbeta)
-         zw(1,0,iv)=zalpha*(1.-zbeta)
-         zw(0,1,iv)=(1.-zalpha)*zbeta
-         zw(1,1,iv)=zalpha*zbeta
-      ENDDO
-
-c   altitude reelle et modele aux points Viking
-      DO iv=1,2
-         phisim(iv)=0.
-         DO jj=0,1
-            j=jvik(iv)+jj
-            DO ii=0,1
-               i=ivik(iv)+ii
-               phisim(iv)=phisim(iv)+zw(ii,jj,iv)*phis(i,j)
-            ENDDO
-         ENDDO
-      ENDDO
-      PRINT*,'relief aux points Viking pour les sorties:',phivik
-
-c----------------------------------------------------------------------
-c   lectures des etats:
-c   -------------------
-
-       airtot1=1./(SSUM(ip1jmp1,aire,1)-SSUM(jjp1,aire,iip1))
-
-c======================================================================
-c   debut de la boucle sur les etats dans un fichier histoire:
-c======================================================================
-       count_ps=(/iip1,jjp1,1/)
-       count_co2ice=(/iip1,jjp1,1/)
-       count_temp=(/iip1,jjp1,llm,1/)
-       
-       DO itau=1,nbpas
-
-       start_ps=(/1,1,itau/)
-       start_co2ice=(/1,1,itau/)
-       start_temp=(/1,1,1,itau/)
-c   lecture drs des champs:
-c   -----------------------
-c         varname='u'
-c         ierr=drsread (unitlec,varname,unat,itau)
-c         PRINT*,'unat',unat(iip1/2,jjp1/2,llm/2)
-c         varname='v'
-c         ierr=drsread (unitlec,varname,vnat,itau)
-c         PRINT*,'vnat',vnat(iip1/2,jjp1/2,llm/2)
-
-ccccccccc  LECTURE Ps ccccccccccccccccccccccccccc
-          ierr = NF_INQ_VARID (nid, "ps", nvarid)
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start_ps,count_ps, ps)
-#else
-          ierr = NF_GET_VARA_REAL(nid, nvarid,start_ps,count_ps, ps)
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, 'xvik: Lecture echouee pour <ps>'
-            CALL abort
-          ENDIF
-          
-          PRINT*,'ps',ps(iip1/2,jjp1/2)
-
-ccccccccc  LECTURE Temperature ccccccccccccccccccccccccccc
-          ierr = NF_INQ_VARID (nid, "temp", nvarid)
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start_temp,count_temp, t)
-#else
-          ierr = NF_GET_VARA_REAL(nid,nvarid,start_temp,count_temp, t)
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, 'xvik: Lecture echouee pour <temp>'
-            ! Ehouarn: proceed anyways
-            ! CALL abort
-            write(*,*)'--> Setting temperature to zero !!!'
-            t(1:iip1,1:jjp1,1:llm)=0.0
-            write(*,*)'--> looking for temp7 (temp in 7th layer)'
-            ierr=NF_INQ_VARID(nid,"temp7", nvarid)
-            if (ierr.eq.NF_NOERR) then
-            write(*,*) "    OK, found temp7 variable"
-#ifdef NC_DOUBLE
-            ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start_ps,count_ps,t7)
-#else
-            ierr=NF_GET_VARA_REAL(nid,nvarid,start_ps,count_ps,t7)
-#endif
-              if (ierr.ne.NF_NOERR) then
-                write(*,*)'xvik: failed loading temp7 !'
-                stop
-              endif
-            else ! no 'temp7' variable
-              write(*,*)'  No temp7 variable either !'
-              write(*,*)'  Will have to to without ...'
-              t7(1:iip1,1:jjp1)=0.0
-            endif
-          ELSE ! t() was successfully loaded, copy 7th layer to t7()
-            t7(1:iip1,1:jjp1)=t(1:iip1,1:jjp1,7)
-          ENDIF
-
-c          PRINT*,'t',t(iip1/2,jjp1/2,llm/2)
-
-ccccccccc  LECTURE co2ice ccccccccccccccccccccccccccc
-          ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start_co2ice,
-     &    count_co2ice,  co2ice)
-#else
-          ierr = NF_GET_VARA_REAL(nid, nvarid,start_co2ice,
-     &    count_co2ice, co2ice)
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, 'xvik: Lecture echouee pour <co2ice>'
-            CALL abort
-          ENDIF
-
-
-c Gestion du temps
-c ----------------
-          day=temps(itau)
-          PRINT*,'day ',day
-          CALL solarlong(day+day0,sollong)
-          sol=day+day0+461.
-          iyear=sol/unanj
-          WRITE (*,*) 'iyear',iyear
-          sol=sol-iyear*unanj
-c
-c Ouverture / fermeture des fichiers
-c ----------------------------------
-          IF (iyear.NE.kyear) THEN
-             WRITE(chr2(1:1),'(i1)') iyear+1
-             WRITE (*,*) 'iyear bis',iyear
-             WRITE (*,*) 'chr2'
-             WRITE (*,*)  chr2
-             IF(iyear.GE.9) WRITE(chr2,'(i2)') iyear+1
-             kyear=iyear
-             DO ii=1,2
-                CLOSE(10+ifile(ii))
-                CLOSE(2+ifile(ii))
-                CLOSE(4+ifile(ii))
-                CLOSE(6+ifile(ii))
-                CLOSE(8+ifile(ii))
-                CLOSE(16+ifile(ii))
-                CLOSE(12+ifile(ii))
-                CLOSE(14+ifile(ii))
-                CLOSE(97)
-                CLOSE(98)
-             ENDDO
-             CLOSE(5+ifile(1))
-             OPEN(ifile(1)+10,file='xpsol1'//chr2,form='formatted')
-             OPEN(ifile(2)+10,file='xpsol2'//chr2,form='formatted')
-c            OPEN(ifile(1)+8,file='xbpsol1'//chr2,form='formatted')
-c            OPEN(ifile(2)+8,file='xbpsol2'//chr2,form='formatted')
-c            OPEN(ifile(1)+2,file='xlps1'//chr2,form='formatted')
-c            OPEN(ifile(2)+2,file='xlps2'//chr2,form='formatted')
-             IF(lcal) THEN
-c               OPEN(ifile(2)+4,file='xpressud'//chr2,form='formatted')
-c               OPEN(ifile(1)+4,file='xpresnord'//chr2,form='formatted')
-c               OPEN(ifile(1)+6,file='xpm2'//chr2,form='formatted')
-             ENDIF
-                         IF(latcal) THEN
-c               OPEN(ifile(2)+14,file='xlats'//chr2,form='formatted')
-c               OPEN(ifile(1)+14,file='xlatn'//chr2,form='formatted')
-                         ENDIF
-             IF(lvent) THEN
-c               OPEN(ifile(1)+16,file='xu1'//chr2,form='formatted')
-c               OPEN(ifile(2)+16,file='xu2'//chr2,form='formatted')
-c               OPEN(ifile(1)+12,file='xv1'//chr2,form='formatted')
-c               OPEN(ifile(2)+12,file='xv2'//chr2,form='formatted')
-             ENDIF
-             OPEN(97,file='xprestot'//chr2,form='formatted')
-c            OPEN(98,file='xlat37_'//chr2,form='formatted')
-           WRITE(98,'(f5.1,16f7.1)') 0.,(rlonv(i)*180./pi,i=1,iim,4)
-          ENDIF
- 
-
-          sollong=sollong*180./pi
-          IF(day_ls) THEN
-             dayw=sol
-             write(*,*) 'dayw', dayw
-          ELSE
-             dayw=sollong
-          ENDIF
-
-c Calcul de la moyenne planetaire
-c -------------------------------
-          pstot=0.
-          captotS=0.
-          captotN=0.
-          DO j=1,jjp1
-             DO i=1,iim
-                pstot=pstot+aire(i,j)*ps(i,j)
-             ENDDO
-          ENDDO
- 
-              DO j=1,jjp1/2
-                 DO i=1,iim
-                    captotN = captotN  +aire(i,j)*co2ice(i,j)
-                 ENDDO
-              ENDDO
-              DO j=jjp1/2+1, jjp1
-                 DO i=1,iim
-                    captotS = captotS  +aire(i,j)*co2ice(i,j)
-                 ENDDO
-              ENDDO
-              WRITE(97,'(4e16.6)') dayw,pstot*airtot1
-     &       , captotN*g*airtot1, captotS*g*airtot1          
-
-          IF(.NOT.firstcal) THEN
-         WRITE(98,'(f5.1,16f7.3)')
-     s    dayw,(ps(i,37),i=1,iim,4)
-
-c boucle sur les sites vikings:
-c ----------------------------
-
-          DO iv=1,2
-
-c interpolation de la temperature dans la 7eme couche, de la pression
-c de surface et des vents aux points viking.
-
-             zp1=0.
-             zp2=0.
-             zp2_sm=0.
-             zt=0.
-             zu=0.
-             zv=0.
-             DO jj=0,1
-                j=jvik(iv)+jj
-                DO ii=0,1
-                   i=ivik(iv)+ii
-!                   zt=zt+zw(ii,jj,iv)*t(i,j,7)
-                   zt=zt+zw(ii,jj,iv)*t7(i,j)
-!                   zp1=zp1+zw(ii,jj,iv)*ps(i,j)
-                   zp1=zp1+zw(ii,jj,iv)*log(ps(i,j)) ! interpolate in log(P)
-                    WRITE (*,*) 'ps autour iv',ps(i,j),iv
-                   zu=zu+zw(ii,jj,iv)*unat(i,j,1)/cu(i,j)
-                   zv=zv+zw(ii,jj,iv)*vnat(i,j,1)/cv(i,j)
-                ENDDO
-             ENDDO
-             zp1=exp(zp1) ! because of the bilinear interpolation in log(P)
- 
-c               pression au sol extrapolee a partir de la temp. 7eme couche
-           WRITE (*,*) 'constR ',constR 
-           WRITE (*,*) 'zt ',zt
-             gh=constR*zt
-             if (gh.eq.0) then ! if we don't have temperature values
-               ! assume a scale height of 10km
-               zp2=zp1*exp(-(phivik(iv)-phisim(iv))/(3.73*1.e4))
-             else
-               zp2=zp1*exp(-(phivik(iv)-phisim(iv))/gh)
-             endif
-           WRITE (*,*) 'iv,pstot,zp2, zp1, phivik(iv),phisim(iv),gh'
-           WRITE (*,*) iv,pstot*airtot1,zp2,zp1,phivik(iv),phisim(iv),gh
-!           WRITE(ifile(iv)+10,'(2e15.5)') dayw,zp1
-           WRITE(ifile(iv)+10,'(3e15.5)') dayw,zp2,zp1
-           
-c   sorties eventuelles de vent
-             IF(lvent) THEN
-                WRITE(ifile(iv)+16,'(2e15.5)')
-     s          dayw,zu
-                WRITE(ifile(iv)+12,'(2e15.5)')
-     s          dayw,zv
-             ENDIF
-          ENDDO
-c         IF (lcal) THEN
-c            WRITE(ifile(1)+4,'(2e15.6)') dayw,airtot1*g*.01*
-c    s       (SSUM(ip1jmp1/2,ziceco2,1)-SSUM(jjp1/2,ziceco2,iip1))
-c            WRITE(ifile(2)+4,'(2e15.6)') dayw,airtot1*g*.01*
-c    s       (SSUM(iip1*jjm/2,ziceco2(1,jjm/2+2),1)-
-c    s       SSUM(jjm/2,ziceco2(1,jjm/2+2),iip1))
-c         ENDIF
-c            IF(latcal) THEN
-c               CALL icelat(iim,jjm,ziceco2,rlatv,zicelat)
-c               WRITE(ifile(1)+14,'(2e15.6)') dayw,zicelat(1)*180./pi
-c               WRITE(ifile(2)+14,'(2e15.6)') dayw,zicelat(2)*180./pi
-c            ENDIF
-         ENDIF
-         firstcal=.false.
-
-c======================================================================
-c   Fin de la boucle sur les etats du fichier histoire:
-c======================================================================
-      ENDDO
-
-      ierr= NF_CLOSE(nid)
-
-      PRINT*,'Fin du fichier',nomfich
-      print*,'Entrer un nouveau fichier ou return pour finir'
-      READ(5,'(a)',err=9999) nomfich
-
-c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-c   Fin de la boucle sur les fichiers histoire:
-c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-      ENDDO
-
-      PRINT*,'relief du point V1',.001*phis(ivik(1),jvik(1))/g
-      PRINT*,'relief du point V2',.001*phis(ivik(2),jvik(2))/g
-      DO iv=1,2
-         PRINT*,'Viking',iv,'   i=',ivik(iv),'j  =',jvik(iv)
-         WRITE(6,7777)
-     s   (rlonv(i)*180./pi,i=ivik(iv)-1,ivik(iv)+2)
-         print*
-         DO j=jvik(iv)-1,jvik(iv)+2
-            WRITE(6,'(f8.1,10x,5f7.1)')
-     s   rlatu(j)*180./pi,(phis(i,j)/(g*1000.),i=ivik(iv)-1,ivik(iv)+2)
-         ENDDO
-         print*
-         print*,'zw'
-         write(6,'(2(2f10.4/))') ((zw(ii,jj,iv),ii=0,1),jj=0,1)
-         print*,'altitude interpolee (km) ',phisim(iv)/1000./g
-      ENDDO
-      PRINT*,'R=',r
- 9999  PRINT*,'Fin '
-
-7777  FORMAT ('latitude/longitude',4f7.1)
-      END
Index: trunk/LMDZ.GENERIC/libf/phystd/datareadnc.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/phystd/datareadnc.F	(revision 987)
+++ trunk/LMDZ.GENERIC/libf/phystd/datareadnc.F	(revision 988)
@@ -1,4 +1,4 @@
 c=======================================================================
-      SUBROUTINE datareadnc(relief,phisinit,alb,ith,
+      SUBROUTINE datareadnc(relief,filename,phisinit,alb,ith,
      .                    zmea,zstd,zsig,zgam,zthe)
 c=======================================================================
@@ -63,20 +63,19 @@
       parameter    (iimp1=iim+1-1/iim)
 
-      CHARACTER relief*3
-
+      character(len=3),intent(inout) :: relief*3
+      character(len=*),intent(in) :: filename ! surface.nc file
+      real,intent(out) :: phisinit(iimp1*jjp1) ! surface geopotential
+      real,intent(out) :: alb(iimp1*jjp1) ! albedo
+      real,intent(out) :: ith(iimp1*jjp1) ! thermal inertia
+      real,intent(out) :: zmea(imdp1*jmdp1)
+      real,intent(out) :: zstd(imdp1*jmdp1)
+      real,intent(out) :: zsig(imdp1*jmdp1)
+      real,intent(out) :: zgam(imdp1*jmdp1)
+      real,intent(out) :: zthe(imdp1*jmdp1)
+      
       REAL        zdata(imd*jmdp1)
       REAL        zdataS(imdp1*jmdp1)
       REAL        pfield(iimp1*jjp1)
 
-      REAL        alb(iimp1*jjp1)
-      REAL        ith(iimp1*jjp1)
-      REAL        phisinit(iimp1*jjp1)
-
-      REAL        zmea(imdp1*jmdp1)
-      REAL        zstd(imdp1*jmdp1)
-      REAL        zsig(imdp1*jmdp1)
-      REAL        zgam(imdp1*jmdp1)
-      REAL        zthe(imdp1*jmdp1)
-
       INTEGER   ierr
 
@@ -96,8 +95,4 @@
       DIMENSION string(4)
 
-      CHARACTER*20 filename
-      CHARACTER*50 filestring
-
-#include "lmdstd.h"
 #include "fxyprim.h"
 
@@ -111,16 +106,4 @@
 c    Lecture NetCDF des donnees latitude et longitude
 c-----------------------------------------------------------------------
-!    First get the corret value of dtadir, if not already done:
-      ! default 'datadir' is set in "datadir_mod"
-      call getin("datadir",datadir)
-      write(*,*) 'Choice of surface data is:'
-      filestring='ls '//trim(datadir)//'/*.nc'
-      call system(filestring)
-
-      write(*,*) ''
-      write(*,*) 'Please choose the relevant file:'
-      write(*,*) '(e.g. type "surface_mars.nc")'
-      read(*,fmt='(a20)') filename
-
       ierr = NF_OPEN (trim(datadir)//'/'//trim(adjustl(filename)),
      &  NF_NOWRITE,unit)
@@ -135,5 +118,5 @@
         write(*,*)' can be obtained online on:'
         write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
-        CALL ABORT
+        STOP
       ENDIF
 
Index: trunk/LMDZ.GENERIC/libf/phystd/lect_start_archive.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/phystd/lect_start_archive.F	(revision 988)
+++ trunk/LMDZ.GENERIC/libf/phystd/lect_start_archive.F	(revision 988)
@@ -0,0 +1,1366 @@
+      SUBROUTINE lect_start_archive(date,tsurf,tsoil,emis,q2,
+     &     t,ucov,vcov,ps,h,phisold_newgrid,
+     &     q,qsurf,surfith,nid)
+
+      USE surfdat_h
+      USE comsoil_h
+      USE tracer_h
+
+c=======================================================================
+c
+c
+c   Auteur:    05/1997 , 12/2003 : coord hybride  FF
+c   ------
+c
+c
+c   Objet:     Lecture des variables d'un fichier "start_archive"
+c              Plus besoin de régler ancienne valeurs grace
+c              a l'allocation dynamique de memoire (Yann Wanherdrick)
+c
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "logic.h"
+#include "description.h"
+#include "ener.h"
+#include "temps.h"
+#include "netcdf.inc"
+#include"advtrac.h"
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Old variables dimensions (from file)
+c------------------------------------
+      INTEGER   imold,jmold,lmold,nsoilold,nqold
+
+
+c Variables pour les lectures des fichiers "ini" 
+c--------------------------------------------------
+!      INTEGER sizei,
+      integer timelen,dimid
+!      INTEGER length
+!      parameter (length = 100)
+      INTEGER tab0
+      INTEGER isoil,iq,iqmax
+      CHARACTER*2   str2
+
+!      REAL dimfirst(4) ! tableau contenant les 1ers elements des dimensions
+
+!      REAL dimlast(4) ! tableau contenant les derniers elements des dimensions
+
+!      REAL dimcycl(4) ! tableau contenant les periodes des dimensions
+!      CHARACTER*120 dimsource
+!      CHARACTER*16 dimname
+!      CHARACTER*80 dimtitle
+!      CHARACTER*40 dimunits
+!      INTEGER   dimtype
+
+!      INTEGER dimord(4)  ! tableau contenant l''ordre
+!      data dimord /1,2,3,4/ ! de sortie des dimensions
+
+!      INTEGER vardim(4)
+      REAL date
+      INTEGER   memo
+!      character (len=50) :: tmpname
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL h(iip1,jjp1,llm),ps(iip1,jjp1)
+      REAL q(iip1,jjp1,llm,nqmx),qtot(iip1,jjp1,llm)
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+
+c!-*-
+!      integer klatdat,klongdat
+!      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx) ! surface temperature
+      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
+      REAL co2ice(ngridmx) ! CO2 ice layer
+      REAL emis(ngridmx)
+      REAL q2(ngridmx,nlayermx+1),qsurf(ngridmx,nqmx)
+c     REAL phisfi(ngridmx)
+
+      INTEGER i,j,l
+      INTEGER nid,nvarid
+c     REAL year_day,periheli,aphelie,peri_day
+c     REAL obliquit,z0,emin_turb,lmixmin
+c     REAL emissiv,emisice(2),albedice(2)
+c     REAL iceradius(2) , dtemisice(2)
+
+      integer ierr
+      integer, dimension(4) :: start,count
+
+c Variable nouvelle grille naturelle au point scalaire
+c------------------------------------------------------
+      real us(iip1,jjp1,llm),vs(iip1,jjp1,llm)
+      REAL phisold_newgrid(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx)
+      real inertiedatS(iip1,jjp1,nsoilmx)
+      real co2iceS(iip1,jjp1)
+      real emisS(iip1,jjp1)
+      REAL q2S(iip1,jjp1,llm+1),qsurfS(iip1,jjp1,nqmx)
+
+      real ptotal, co2icetotal
+
+c Var intermediaires : vent naturel, mais pas coord scalaire
+c-----------------------------------------------------------
+      real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
+
+
+c Variable de l'ancienne grille 
+c---------------------------------------------------------
+
+      real, dimension(:), allocatable :: timelist
+      real, dimension(:), allocatable :: rlonuold, rlatvold
+      real, dimension(:), allocatable :: rlonvold, rlatuold
+      real, dimension(:), allocatable :: apsold,bpsold
+      real, dimension(:), allocatable :: mlayerold
+      real, dimension(:,:,:), allocatable :: uold,vold,told,q2old
+      real, dimension(:,:,:), allocatable :: tsoilold,qsurfold
+      real, dimension(:,:,:),allocatable :: tsoiloldnew
+! tsoiloldnew: old soil values, but along new subterranean grid
+      real, dimension(:,:,:), allocatable :: inertiedatold
+! inertiedatoldnew: old inertia values, but along new subterranean grid
+      real, dimension(:,:,:), allocatable :: inertiedatoldnew
+      real, dimension(:,:), allocatable :: psold,phisold
+      real, dimension(:,:), allocatable :: co2iceold
+      real, dimension(:,:), allocatable :: tsurfold
+      real, dimension(:,:), allocatable :: emisold
+      real, dimension(:,:,:,:), allocatable :: qold
+
+      real tab_cntrl(100)
+
+      real ptotalold, co2icetotalold
+
+      logical :: olddepthdef=.false. ! flag
+! olddepthdef=.true. if soil depths are in 'old' (unspecified) format
+      logical :: depthinterpol=.false. ! flag
+! depthinterpol=.true. if interpolation will be requiered
+      logical :: therminertia_3D=.true. ! flag
+! therminertia_3D=.true. if thermal inertia is 3D and read from datafile
+c Variable intermediaires iutilise pour l'extrapolation verticale 
+c----------------------------------------------------------------
+      real, dimension(:,:,:), allocatable :: var,varp1 
+      real, dimension(:), allocatable :: oldgrid, oldval
+      real, dimension(:), allocatable :: newval
+
+      real surfith(iip1,jjp1) ! surface thermal inertia
+      ! surface thermal inertia at old horizontal grid resolution
+      real, dimension(:,:), allocatable :: surfithold 
+
+      character(len=30) :: txt ! to store some text
+
+c=======================================================================
+
+! 0. Preliminary stuff
+
+
+
+!-----------------------------------------------------------------------
+! 1. Read data dimensions (i.e. size and length)
+!-----------------------------------------------------------------------
+
+! 1.2 Read the various dimension lengths of data in file 
+
+      ierr= NF_INQ_DIMID(nid,"Time",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"temps",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
+
+      ierr= NF_INQ_DIMID(nid,"latitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlatu",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,jmold)
+      jmold=jmold-1
+
+      ierr= NF_INQ_DIMID(nid,"longitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlonv",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,imold)
+      imold=imold-1
+
+      ierr= NF_INQ_DIMID(nid,"altitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"sig_s",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,lmold)
+
+      nqold=0
+      do
+         write(str2,'(i2.2)') nqold+1
+         ierr= NF_INQ_VARID(nid,'q'//str2,dimid)
+!        write(*,*) 'q'//str2
+         if (ierr.eq.NF_NOERR) then
+            nqold=nqold+1
+         else
+            exit
+         endif
+      enddo
+
+! 1.2.1 find out the # of subsurface_layers
+      nsoilold=0 !dummy initialisation
+      ierr=NF_INQ_DIMID(nid,"subsurface_layers",dimid)
+      if (ierr.eq.NF_NOERR) then
+        ierr=NF_INQ_DIMLEN(nid,dimid,nsoilold)
+	if (ierr.ne.NF_NOERR) then
+	 write(*,*)'lec_start_archive: ',
+     &              'Failed reading subsurface_layers length'
+	endif
+      else
+        write(*,*)"lec_start_archive: did not find subsurface_layers"
+      endif
+
+      if (nsoilold.eq.0) then ! 'old' archive format;
+      ! must use Tg//str2 fields to compute nsoilold
+      write(*,*)"lec_start_archive: building nsoilold from Tg fields"
+        do
+	 write(str2,'(i2.2)') nsoilold+1
+	 ierr=NF_INQ_VARID(nid,'Tg'//str2,dimid)
+	 if (ierr.eq.NF_NOERR) then
+	  nsoilold=nsoilold+1
+	 else
+	  exit
+	 endif
+	enddo
+      endif
+
+
+      if (nsoilold.ne.nsoilmx) then ! interpolation will be required
+        depthinterpol=.true.
+      endif
+
+! 1.3 Report dimensions
+      
+      write(*,*) "Start_archive dimensions:"
+      write(*,*) "longitude: ",imold
+      write(*,*) "latitude: ",jmold
+      write(*,*) "altitude: ",lmold
+      write(*,*) "tracers: ",nqold
+      write(*,*) "subsurface_layers: ",nsoilold
+      if (depthinterpol) then
+      write(*,*) " => Warning, nsoilmx= ",nsoilmx
+      write(*,*) '    which implies that you want subterranean interpola
+     &tion.'
+      write(*,*) '  Otherwise, set nsoilmx -in dimphys.h- to: ',nsoilold
+      endif
+      write(*,*) "time lenght: ",timelen
+      write(*,*) 
+
+!-----------------------------------------------------------------------
+! 2. Allocate arrays to store datasets
+!-----------------------------------------------------------------------
+
+      allocate(timelist(timelen))
+      allocate(rlonuold(imold+1), rlatvold(jmold))
+      allocate(rlonvold(imold+1), rlatuold(jmold+1))
+      allocate (apsold(lmold),bpsold(lmold))
+      allocate(uold(imold+1,jmold+1,lmold))
+      allocate(vold(imold+1,jmold+1,lmold))
+      allocate(told(imold+1,jmold+1,lmold))
+      allocate(psold(imold+1,jmold+1))
+      allocate(phisold(imold+1,jmold+1))
+      allocate(qold(imold+1,jmold+1,lmold,nqmx))
+      allocate(co2iceold(imold+1,jmold+1))
+      allocate(tsurfold(imold+1,jmold+1))
+      allocate(emisold(imold+1,jmold+1))
+      allocate(q2old(imold+1,jmold+1,lmold+1))
+!      allocate(tsoilold(imold+1,jmold+1,nsoilmx))
+      allocate(tsoilold(imold+1,jmold+1,nsoilold))
+      allocate(tsoiloldnew(imold+1,jmold+1,nsoilmx))
+      allocate(inertiedatold(imold+1,jmold+1,nsoilold)) ! soil thermal inertia
+      allocate(inertiedatoldnew(imold+1,jmold+1,nsoilmx))
+      ! surface thermal inertia at old horizontal grid resolution
+      allocate(surfithold(imold+1,jmold+1))
+      allocate(mlayerold(nsoilold))
+      allocate(qsurfold(imold+1,jmold+1,nqmx))
+
+      allocate(var (imold+1,jmold+1,llm))
+      allocate(varp1 (imold+1,jmold+1,llm+1))
+
+      write(*,*) 'q2',ngridmx,nlayermx+1
+      write(*,*) 'q2S',iip1,jjp1,llm+1
+      write(*,*) 'q2old',imold+1,jmold+1,lmold+1
+
+!-----------------------------------------------------------------------
+! 3. Read time-independent data
+!-----------------------------------------------------------------------
+
+C-----------------------------------------------------------------------
+c 3.1. Lecture du tableau des parametres du run 
+c     (pour  la lecture ulterieure de "ptotalold" et "co2icetotalold")
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Lect_start_archive: champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+c
+      tab0 = 50
+
+c-----------------------------------------------------------------------
+c 3.2 Lecture des longitudes et latitudes
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatv>"
+         CALL abort
+      ENDIF
+c
+
+c-----------------------------------------------------------------------
+c 3.3. Lecture des niveaux verticaux
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "aps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <aps> est absent"
+         apsold=0
+         PRINT*, "<aps> set to 0"
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apsold)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, apsold)
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Lecture echouee pour <aps>"
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "bps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <bps> est absent"
+         PRINT*, "It must be an old start_archive, lets look for sig_s"
+         ierr = NF_INQ_VARID (nid, "sig_s", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "Nothing to do..."
+            CALL abort
+         ENDIF
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpsold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, bpsold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <bps>"
+         CALL abort
+      END IF
+
+c-----------------------------------------------------------------------
+c 3.4 Read Soil layers depths
+c-----------------------------------------------------------------------
+     
+      ierr=NF_INQ_VARID(nid,"soildepth",nvarid)
+      if (ierr.ne.NF_NOERR) then
+       write(*,*)'lect_start_archive: Could not find <soildepth>'
+       write(*,*)' => Assuming this is an archive in old format'
+       olddepthdef=.true.
+       depthinterpol=.true.
+       ! this is how soil depth was defined in ye old days
+	do isoil=1,nsoilold
+	  mlayerold(isoil)=sqrt(887.75/3.14)*((2.**(isoil-0.5))-1.)
+	enddo
+      else
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayerold)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayerold)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <soildepth>"
+         CALL abort
+       endif
+
+      endif !of if(ierr.ne.NF_NOERR)
+
+      ! Read (or build) mlayer()
+      if (depthinterpol) then
+       ! Build (default) new soil depths (mlayer(:) is in comsoil.h),
+       ! as in soil_settings.F
+       write(*,*)' => Building default soil depths'
+       do isoil=0,nsoilmx-1
+         mlayer(isoil)=2.e-4*(2.**(isoil-0.5))
+       enddo
+       write(*,*)' => mlayer: ',mlayer
+       ! Also build (default) new soil interlayer depth layer(:)
+       do isoil=1,nsoilmx
+         layer(isoil)=sqrt(mlayer(0)*mlayer(1))*
+     &                      ((mlayer(1)/mlayer(0))**(isoil-1))
+       enddo
+       write(*,*)' =>  layer: ',layer
+      else ! read mlayer() from file
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayer)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,mlayer)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <soildepth>"
+         CALL abort
+       endif
+      endif ! of if (depthinterpol)
+
+c-----------------------------------------------------------------------
+c 3.5 Read Soil thermal inertia
+c-----------------------------------------------------------------------
+
+      ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
+      if (ierr.ne.NF_NOERR) then
+       write(*,*)'lect_start_archive: Could not find <inertiedat>'
+       write(*,*)' => Assuming this is an archive in old format'
+       therminertia_3D=.false.
+       write(*,*)' => Thermal inertia will be read from reference file'
+       volcapa=1.e6
+       write(*,*)'    and soil volumetric heat capacity is set to ',
+     &           volcapa
+      else
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid,nvarid,inertiedatold)
+#else
+        ierr = NF_GET_VAR_REAL(nid,nvarid,inertiedatold)
+#endif
+       if (ierr .NE. NF_NOERR) then
+         PRINT*, "lect_start_archive: Failed reading <inertiedat>"
+         CALL abort
+       endif
+      endif
+
+c-----------------------------------------------------------------------
+c 3.6 Lecture geopotentiel au sol
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+C-----------------------------------------------------------------------
+c   lecture de "ptotalold" et "co2icetotalold"
+c-----------------------------------------------------------------------
+      ptotalold = tab_cntrl(tab0+49)
+      co2icetotalold = tab_cntrl(tab0+50)
+ 
+c-----------------------------------------------------------------------
+c 4. Lecture du temps et choix
+c-----------------------------------------------------------------------
+ 
+c  lecture du temps
+c
+      ierr = NF_INQ_DIMID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_DIMID (nid, "temps", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Le champ <Time> est absent"
+            CALL abort
+         endif
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      endif 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, timelist)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, timelist)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <Time>"
+         CALL abort
+      ENDIF
+c
+      write(*,*)
+      write(*,*)
+      write(*,*) 'Differentes dates des etats initiaux stockes:'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      pi=2.*ASIN(1.)
+      do i=1,timelen
+c       call solarlong(timelist(i),sollong(i))
+c       sollong(i) = sollong(i)*180./pi
+        write(*,*) 'etat initial au jour martien' ,int(timelist(i))
+c       write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)),
+c    .    sollong(i)
+      end do
+
+   6  FORMAT(i7,i7,f9.3)
+ 
+      write(*,*)
+      write(*,*) 'Choix de la date'
+ 123  read(*,*,iostat=ierr) date
+      if(ierr.ne.0) goto 123
+      memo = 0
+      do i=1,timelen
+        if (date.eq.int(timelist(i))) then
+            memo = i
+        endif
+      end do
+ 
+      if (memo.eq.0) then
+        write(*,*)
+        write(*,*)
+        write(*,*) 'He alors... Y sait pas lire !?!'
+        write(*,*)
+        write(*,*) 'Differentes dates des etats initiaux stockes:'
+        write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+        do i=1,timelen
+          write(*,*) 'etat initial au jour martien' ,nint(timelist(i))
+c         write(*,6) nint(timelist(i)),nint(mod(timelist(i),669))
+        end do
+        goto 123
+      endif
+
+!-----------------------------------------------------------------------
+! 5. Read (time-dependent) data from datafile
+!-----------------------------------------------------------------------
+
+
+c-----------------------------------------------------------------------
+c 5.1 Lecture des champs 2D (co2ice, emis,ps,tsurf,Tg[10], qsurf)
+c-----------------------------------------------------------------------
+ 
+      start=(/1,1,memo,0/)
+      count=(/imold+1,jmold+1,1,0/)
+       
+! CO2ice is now in qsurf(igcm_co2_ice) ...
+!      ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
+!      IF (ierr .NE. NF_NOERR) THEN
+!         PRINT*, "lect_start_archive: Le champ <co2ice> est absent"
+!         CALL abort
+!      ENDIF
+!#ifdef NC_DOUBLE
+!      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,co2iceold)
+!#else
+!      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,co2iceold)
+!#endif
+!      IF (ierr .NE. NF_NOERR) THEN
+!         PRINT*, "lect_start_archive: Lecture echouee pour <co2ice>"
+!         PRINT*, NF_STRERROR(ierr)
+!         CALL abort
+!      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "emis", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <emis> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,emisold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,emisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <emis>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,psold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,psold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "tsurf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <tsurf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,tsurfold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,tsurfold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <tsurf>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "q2surf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2surf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2surf>"
+         CALL abort
+      ENDIF
+c
+      write(*,*)"lect_start_archive: rlonuold:"
+     &           ,rlonuold," rlatvold:",rlatvold
+      write(*,*)
+
+! Surface tracers:      
+      do iq=1,nqmx
+        ! initialize all surface tracers to zero
+        call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+      enddo
+
+
+!      print*,'tnom=',tnom
+!      print*,'nid',nid
+!      print*,'nvarid',nvarid
+!      stop
+
+      DO iq=1,nqmx
+          txt=trim(tnom(iq))//"_surf"
+          if (txt.eq."h2o_vap") then
+            ! There is no surface tracer for h2o_vap;
+            ! "h2o_ice" should be loaded instead
+            txt="h2o_ice_surf"
+            write(*,*) 'lect_start_archive: loading surface tracer',
+     &                     ' h2o_ice instead of h2o_vap'
+          endif
+
+        
+        write(*,*) "lect_start_archive: loading tracer ",trim(txt)
+        ierr = NF_INQ_VARID (nid,txt,nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &              " Tracer <",trim(txt),"> not found"
+
+!          print*,'RDW has added hack to let me continue...'
+!          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     &          qsurfold(1,1,iq))
+#else
+        ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     &          qsurfold(1,1,iq))
+#endif
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &             " Failed loading <",trim(txt),">"
+          write (*,*) trim(txt),'    is set to 0'
+!          call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+        ENDIF
+
+      ENDDO ! of DO iq=1,nqmx
+
+
+!-----------------------------------------------------------------------
+! 5.2 Read 3D subterranean fields
+!-----------------------------------------------------------------------
+
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,nsoilold,1/)
+!
+! Read soil temperatures
+!
+      if (olddepthdef) then ! tsoil stored using the 'old format'
+         start=(/1,1,memo,0/)
+         count=(/imold+1,jmold+1,1,0/) ! because the "Tg" are 2D datasets
+       do isoil=1,nsoilold
+         write(str2,'(i2.2)') isoil
+c
+         ierr = NF_INQ_VARID (nid, "Tg"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &              "Field <","Tg"//str2,"> not found"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     &          tsoilold(1,1,isoil))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     &          tsoilold(1,1,isoil))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &            "Failed reading <","Tg"//str2,">"
+            CALL abort
+         ENDIF
+c
+       enddo ! of do isoil=1,nsoilold
+      
+      ! reset 'start' and 'count' to "3D" behaviour
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,nsoilold,1/)
+      
+      else
+       write(*,*) "lect_start_archive: loading tsoil "
+       ierr=NF_INQ_VARID(nid,"tsoil",nvarid)
+       if (ierr.ne.NF_NOERR) then
+        write(*,*)"lect_start_archive: Cannot find <tsoil>"
+	call abort
+       else
+#ifdef NC_DOUBLE
+      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,tsoilold)
+#else
+      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,tsoilold)
+#endif
+       endif ! of if (ierr.ne.NF_NOERR)
+       
+      endif ! of if (olddepthdef)
+
+!
+! Read soil thermal inertias
+!
+!      if (.not.olddepthdef) then ! no thermal inertia data in "old" archives
+!       ierr=NF_INQ_VARID(nid,"inertiedat",nvarid)
+!       if (ierr.ne.NF_NOERR) then
+!        write(*,*)"lect_start_archive: Cannot find <inertiedat>"
+!	call abort
+!       else
+!#ifdef NC_DOUBLE
+!      ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,inertiedatold)
+!#else
+!      ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,inertiedatold)
+!#endif
+!       endif ! of if (ierr.ne.NF_NOERR)
+!      endif
+
+c-----------------------------------------------------------------------
+c 5.3	Lecture des champs 3D (t,u,v, q2atm,q)
+c-----------------------------------------------------------------------
+
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,lmold,1/)
+
+c
+      ierr = NF_INQ_VARID (nid,"temp", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <temp> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, count, told)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid, start, count, told)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <temp>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"u", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <u> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,uold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,uold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <u>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"v", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <v> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,vold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,vold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <v>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"q2atm", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2atm> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old(1,1,2))
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old(1,1,2))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2atm>"
+         CALL abort
+      ENDIF
+c
+
+! Tracers:      
+      do iq=1,nqmx
+         call initial0((jmold+1)*(imold+1)*lmold,qold(1,1,1,iq) )
+      enddo
+
+      DO iq=1,nqmx
+        txt=tnom(iq)
+        write(*,*)"lect_start_archive: loading tracer ",trim(txt)
+        ierr = NF_INQ_VARID (nid,txt,nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: ",
+     &              " Tracer <",trim(txt),"> not found"
+!            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr=NF_GET_VARA_DOUBLE(nid,nvarid,start,count,qold(1,1,1,iq))
+#else
+        ierr=NF_GET_VARA_REAL(nid,nvarid,start,count,qold(1,1,1,iq))
+#endif
+        IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "lect_start_archive: ",
+     &             "  Failed loading <",trim(txt),">"
+          write (*,*) trim(txt),'      set to 1.E-30'
+          do l=1,lmold
+            do j=1,jmold+1
+              do i=1,imold+1
+                 qold(i,j,l,iq)=1.e-30
+              end do
+            end do
+          end do
+        ENDIF
+
+      ENDDO ! of DO iq=1,nqmx
+
+
+!=======================================================================
+! 6. Interpolation from old grid to new grid
+!=======================================================================
+
+c=======================================================================
+c   INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables
+c=======================================================================
+c  Interpolation horizontale puis passage dans la grille physique pour 
+c  les variables physique 
+c  Interpolation verticale puis horizontale pour chaque variable 3D
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c 6.1	Variable 2d :
+c-----------------------------------------------------------------------
+c Relief 
+      call interp_horiz (phisold,phisold_newgrid,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+! CO2 ice is now in qsurf(igcm_co2_ice)
+!      call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1,
+!     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c Temperature de surface
+      call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf)
+c     write(44,*) 'tsurf', tsurf
+
+c Temperature du sous-sol
+!      call interp_horiz(tsoilold,tsoils,
+!     &                  imold,jmold,iim,jjm,nsoilmx,
+!     &                   rlonuold,rlatvold,rlonu,rlatv)
+!      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil)
+c     write(45,*) 'tsoil',tsoil
+
+c Emissivite de la surface
+      call interp_horiz (emisold,emiss,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,emiss,emis)
+c     write(46,*) 'emis',emis
+c-----------------------------------------------------------------------
+c 6.1.2	Traitement special de la pression au sol :
+c-----------------------------------------------------------------------
+
+c  Extrapolation la pression dans la nouvelle grille
+      call interp_horiz(psold,ps,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c-----------------------------------------------------------------------
+c	On assure la conservation de la masse de l'atmosphere + calottes
+c-----------------------------------------------------------------------
+
+      ptotal =  0.
+      DO j=1,jjp1
+         DO i=1,iim
+            ptotal=ptotal+ps(i,j)*aire(i,j)/g
+         END DO
+      END DO
+      co2icetotal = 0.
+      if (igcm_co2_ice.ne.0) then
+        ! recast surface CO2 ice on new grid
+        call interp_horiz(qsurfold(1,1,igcm_co2_ice),
+     &                  qsurfs(1,1,igcm_co2_ice),
+     &                  imold,jmold,iim,jjm,1,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+       DO j=1,jjp1
+         DO i=1,iim
+           !co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
+           co2icetotal=co2icetotal+qsurfS(i,j,igcm_co2_ice)*aire(i,j)
+         END DO
+       END DO
+      else
+        write(*,*) "Warning: No co2_ice surface tracer"
+      endif
+
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de l atm :',ptotalold
+      write(*,*)'Nouvelle grille: masse de l atm :',ptotal
+      write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold 
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold
+      write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal
+      if (co2icetotalold.ne.0.) then
+      write(*,*)'Ratio new ice./old ice =',co2icetotal/co2icetotalold
+      endif
+      write(*,*)
+
+
+      DO j=1,jjp1
+         DO i=1,iip1
+            ps(i,j)=ps(i,j) * ptotalold/ptotal
+         END DO
+      END DO
+
+      if ( co2icetotalold.gt.0.) then 
+!         DO j=1,jjp1
+!            DO i=1,iip1
+!               co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal
+!            END DO
+!         END DO
+        write(*,*) "Not enforcing conservation of surface CO2 ice"
+        write(*,*) " (should be OK when CO2 ice is a tracer)"
+      end if
+
+c-----------------------------------------------------------------------
+c 6.2 Subterranean 3d variables:
+c-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c 6.2.1 Thermal Inertia
+c       Note: recall that inertiedat is a common in "comsoil.h"
+c-----------------------------------------------------------------------
+
+      ! depth-wise interpolation, if required
+      if (depthinterpol.and.(.not.olddepthdef)) then
+        allocate(oldval(nsoilold))
+	allocate(newval(nsoilmx))
+        write(*,*)'lect_start_archive: WARNING: vertical interpolation o
+     &f soil thermal inertia; might be wiser to reset it.'
+        write(*,*)
+       
+        do i=1,imold+1
+         do j=1,jmold+1
+	   !copy old values
+	   oldval(1:nsoilold)=inertiedatold(i,j,1:nsoilold)
+	   !interpolate
+	   call interp_line(mlayerold,oldval,nsoilold,
+     &                     mlayer,newval,nsoilmx)
+           !copy interpolated values
+           inertiedatoldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+        enddo
+        ! cleanup
+	deallocate(oldval)
+	deallocate(newval)
+      endif !of if (depthinterpol)
+
+      if (therminertia_3D) then
+        ! We have inertiedatold
+       if((imold.ne.iim).or.(jmold.ne.jjm)) then
+       write(*,*)'lect_start_archive: WARNING: horizontal interpolation 
+     &of thermal inertia; might be better to reset it.'
+       write(*,*)
+       endif
+       
+        ! Do horizontal interpolation
+	if (depthinterpol) then
+	  call interp_horiz(inertiedatoldnew,inertiedatS,
+     &                  imold,jmold,iim,jjm,nsoilmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+	else
+          call interp_horiz(inertiedatold,inertiedatS,
+     &                  imold,jmold,iim,jjm,nsoilold,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+        endif ! of if (depthinterpol)
+
+      else ! no 3D thermal inertia data
+       write(*,*)'lect_start_archive: using reference surface inertia'
+        ! Use surface inertia (and extend it to all depths)
+        do i=1,nsoilmx
+         inertiedatS(1:iip1,1:jjp1,i)=surfith(1:iip1,1:jjp1)
+        enddo
+	! Build an old resolution surface thermal inertia
+	! (will be needed for tsoil interpolation)
+	call interp_horiz(surfith,surfithold,
+     &                    iim,jjm,imold,jmold,1,
+     &                    rlonu,rlatv,rlonuold,rlatvold)
+      endif
+
+
+      ! Reshape inertiedatS to scalar grid as inertiedat
+      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,
+     &                  inertiedatS,inertiedat)
+      
+c-----------------------------------------------------------------------
+c 6.2.2 Soil temperature
+c-----------------------------------------------------------------------
+!      write(*,*) 'Soil'
+
+      !print*,'Problem in lect_start_archive interpolating'
+      !print*,'to new resolution!!'
+
+      ! Recast temperatures along soil depth, if necessary
+      if (olddepthdef) then
+        allocate(oldgrid(nsoilold+1))
+        allocate(oldval(nsoilold+1))
+	allocate(newval(nsoilmx))
+        do i=1,imold+1
+	 do j=1,jmold+1
+
+            !if(i.gt.iip1 .or. j.gt.jjp1)then
+               !print*,'Problem in lect_start_archive interpolating'
+               !print*,'to new resolution!!'
+               !call abort
+            !endif
+
+	   ! copy values
+	   oldval(1)=tsurfold(i,j)
+!	   oldval(1)=tsurfS(i,j)
+	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
+	   ! build vertical coordinate
+	   oldgrid(1)=0. ! ground
+	   oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)*
+     &                (surfithold(i,j)/1.e6)
+          ! Note; at this stage, we impose volcapa=1.e6 above
+	  ! since volcapa isn't set in old soil definitions
+
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,nsoilold+1,
+     &                     mlayer,newval,nsoilmx)
+	 ! copy result in tsoilold
+	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+	enddo
+        ! cleanup
+	deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+
+      else
+       if (depthinterpol) then ! if vertical interpolation is required
+        allocate(oldgrid(nsoilold+1))
+        allocate(oldval(nsoilold+1))
+	allocate(newval(nsoilmx))
+        ! build vertical coordinate
+	oldgrid(1)=0. ! ground
+	oldgrid(2:nsoilold+1)=mlayerold(1:nsoilold)
+        do i=1,imold+1
+	 do j=1,jmold+1
+	   ! copy values
+	   oldval(1)=tsurfold(i,j)
+!	   oldval(1)=tsurfS(i,j)
+	   oldval(2:nsoilold+1)=tsoilold(i,j,1:nsoilold)
+	  ! interpolate
+	  call interp_line(oldgrid,oldval,nsoilold+1,
+     &                     mlayer,newval,nsoilmx)
+	 ! copy result in tsoilold
+	 tsoiloldnew(i,j,1:nsoilmx)=newval(1:nsoilmx)
+	 enddo
+	enddo
+!	write(*,*)'tsoiloldnew(1,1,1):',tsoiloldnew(1,1,1)
+        ! cleanup
+	deallocate(oldgrid)
+	deallocate(oldval)
+	deallocate(newval)
+       
+       else
+        tsoiloldnew(:,:,:)=tsoilold(:,:,:)
+       endif ! of if (depthinterpol)
+      endif ! of if (olddepthdef)
+
+      ! Do the horizontal interpolation
+       call interp_horiz(tsoiloldnew,tsoilS,
+     &                  imold,jmold,iim,jjm,nsoilmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+      ! Reshape tsoilS to scalar grid as tsoil
+       call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoilS,tsoil)
+
+
+
+c-----------------------------------------------------------------------
+c 6.3 Variable 3d :
+c-----------------------------------------------------------------------
+      
+c temperatures atmospheriques
+      write (*,*) 'lect_start_archive: told ', told (1,jmold+1,1)  ! INFO
+      call interp_vert
+     &    (told,var,lmold,llm,apsold,bpsold,aps,bps,
+     &     psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: var ', var (1,jmold+1,1)  ! INFO
+      call interp_horiz(var,t,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: t ', t(1,jjp1,1)  ! INFO
+
+c q2 : pbl wind variance
+      write (*,*) 'lect_start_archive: q2old ', q2old (1,2,1)  ! INFO
+      call interp_vert (q2old,varp1,lmold+1,llm+1,
+     &     apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: varp1 ', varp1 (1,2,1)  ! INFO
+      call interp_horiz(varp1,q2s,imold,jmold,iim,jjm,llm+1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: q2s ', q2s (1,2,1)  ! INFO
+      call gr_dyn_fi (llm+1,iim+1,jjm+1,ngridmx,q2s,q2)
+      write (*,*) 'lect_start_archive: q2 ', q2 (1,2)  ! INFO
+c     write(47,*) 'q2',q2
+
+c calcul des champ de vent; passage en vent covariant
+      write (*,*) 'lect_start_archive: uold ', uold (1,2,1)  ! INFO
+      call interp_vert
+     & (uold,var,lmold,llm,apsold,bpsold,aps,bps,
+     &  psold,(imold+1)*(jmold+1))
+      write (*,*) 'lect_start_archive: var ', var (1,2,1)  ! INFO
+      call interp_horiz(var,us,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'lect_start_archive: us ', us (1,2,1)   ! INFO
+
+      call interp_vert
+     & (vold,var,lmold,llm,
+     &  apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      call interp_horiz(var,vs,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call scal_wind(us,vs,unat,vnat)
+      write (*,*) 'lect_start_archive: unat ', unat (1,2,1)    ! INFO
+      do l=1,llm
+        do j = 1, jjp1
+          do i=1,iip1
+            ucov( i,j,l ) = unat( i,j,l ) * cu(i,j)
+c           ucov( i,j,l ) = 0
+          end do
+        end do
+      end do 
+      write (*,*) 'lect_start_archive: ucov ', ucov (1,2,1)  ! INFO
+c     write(48,*) 'ucov',ucov
+      do l=1,llm
+        do j = 1, jjm
+          do i=1,iim
+            vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j)
+c           vcov( i,j,l ) = 0
+          end do
+          vcov( iip1,j,l ) = vcov( 1,j,l )
+        end do
+      end do
+c     write(49,*) 'ucov',vcov
+
+      if (nqmx .gt. 0) then
+c traceurs surface
+      do iq = 1, nqmx
+            call interp_horiz(qsurfold(1,1,iq) ,qsurfs(1,1,iq),
+     &                  imold,jmold,iim,jjm,1,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+
+      call gr_dyn_fi (nqmx,iim+1,jjm+1,ngridmx,qsurfs,qsurf)
+
+c traceurs 3D
+      do  iq = 1, nqmx
+            call interp_vert(qold(1,1,1,iq),var,lmold,llm,
+     &        apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+            call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+cccccccccccccccccccccccccccccc      
+c  make sure that sum of q = 1      
+c dominent species is = 1 - sum(all other species)      
+cccccccccccccccccccccccccccccc      
+c      iqmax=1
+c      
+c      if (nqold.gt.10) then
+c       do l=1,llm
+c        do j=1,jjp1
+c          do i=1,iip1
+c           do iq=1,nqold
+c            if (q(i,j,l,iq).gt.q(i,j,l,iqmax)) then
+c              iqmax=iq
+c            endif
+c           enddo
+c           q(i,j,l,iqmax)=1.
+c           qtot(i,j,l)=0
+c           do iq=1,nqold
+c            if (iq.ne.iqmax) then        
+c              q(i,j,l,iqmax)=q(i,j,l,iqmax)-q(i,j,l,iq)        
+c            endif
+c           enddo !iq
+c           do iq=1,nqold
+c            qtot(i,j,l)=qtot(i,j,l)+q(i,j,l,iq)
+c            if (i.eq.1.and.j.eq.1.and.l.Eq.1) write(*,*)' qtot(i,j,l)',
+c     $    qtot(i,j,l)
+c           enddo !iq
+c          enddo !i   
+c         enddo !j   
+c       enddo !l  
+c      endif
+ccccccccccccccccccccccccccccccc
+
+c     Periodicite :
+      do  iq = 1, nqmx
+         do l=1, llm
+            do j = 1, jjp1
+               q(iip1,j,l,iq) = q(1,j,l,iq)
+            end do
+         end do
+      enddo
+      
+!      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice)
+! no need to transfer "co2ice" any more; it is in qsurf(igcm_co2_ice)
+
+      endif !! if nqmx .ne. 0
+
+c-----------------------------------------------------------------------
+c   Initialisation  h:	(passage de t -> h)
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         DO j=1,jjp1
+            DO i=1,iim
+               h(i,j,l) = t(i,j,l)*((ps(i,j)/preff)**kappa)
+            END DO
+            h(iip1,j,l) =  h(1,j,l)
+         END DO
+      END DO
+
+
+c***********************************************************************
+c***********************************************************************
+c     Fin subroutine lecture ini
+c***********************************************************************
+c***********************************************************************
+
+      deallocate(timelist)
+      deallocate(rlonuold, rlatvold)
+      deallocate(rlonvold, rlatuold)
+      deallocate(apsold,bpsold)
+      deallocate(uold)
+      deallocate(vold)
+      deallocate(told)
+      deallocate(psold)
+      deallocate(phisold)
+      deallocate(qold)
+      deallocate(co2iceold)
+      deallocate(tsurfold)
+      deallocate(emisold)
+      deallocate(q2old)
+      deallocate(tsoilold)
+      deallocate(tsoiloldnew)
+      deallocate(inertiedatold)
+      deallocate(inertiedatoldnew)
+      deallocate(surfithold)
+      deallocate(mlayerold)
+      deallocate(qsurfold)
+      deallocate(var,varp1)
+
+!      write(*,*)'lect_start_archive: END'
+      return
+      end
Index: trunk/LMDZ.GENERIC/libf/phystd/newstart.F
===================================================================
--- trunk/LMDZ.GENERIC/libf/phystd/newstart.F	(revision 988)
+++ trunk/LMDZ.GENERIC/libf/phystd/newstart.F	(revision 988)
@@ -0,0 +1,1501 @@
+C======================================================================
+      PROGRAM newstart
+c=======================================================================
+c
+c
+c   Auteur:   Christophe Hourdin/Francois Forget/Yann Wanherdrick
+c   ------
+c             Derniere modif : 12/03
+c
+c
+c   Objet:  Create or modify the initial state for the LMD Mars GCM
+c   -----           (fichiers NetCDF start et startfi)
+c
+c
+c=======================================================================
+
+      USE tracer_h
+      USE comsoil_h
+      USE surfdat_h
+      USE comgeomfi_h
+      use datafile_mod, only: datadir
+! to use  'getin'
+      USE ioipsl_getincom, only: getin
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "logic.h"
+#include "description.h"
+#include "ener.h"
+#include "temps.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+#include "serre.h"
+#include "netcdf.inc"
+#include "advtrac.h"
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Variables dimension du fichier "start_archive"
+c------------------------------------
+      CHARACTER	relief*3
+
+
+c Variables pour les lectures NetCDF des fichiers "start_archive" 
+c--------------------------------------------------
+      INTEGER nid_dyn, nid_fi,nid,nvarid
+      INTEGER length
+      parameter (length = 100)
+      INTEGER tab0
+      INTEGER   NB_ETATMAX
+      parameter (NB_ETATMAX = 100)
+
+      REAL  date
+      REAL p_rad,p_omeg,p_g,p_cpp,p_mugaz,p_daysec
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL phis(iip1,jjp1)
+      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+      REAL pks(iip1,jjp1)
+      REAL w(iip1,jjp1,llm+1)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+!      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+!      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
+      REAL phi(iip1,jjp1,llm)
+
+      integer klatdat,klongdat
+      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
+      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx)	! surface temperature
+      REAL tsoil(ngridmx,nsoilmx) ! soil temperature
+!      REAL co2ice(ngridmx)	! CO2 ice layer
+      REAL emis(ngridmx)	! surface emissivity
+      real emisread             ! added by RW
+      REAL qsurf(ngridmx,nqmx)
+      REAL q2(ngridmx,nlayermx+1)
+!      REAL rnaturfi(ngridmx)
+      real alb(iip1,jjp1),albfi(ngridmx) ! albedos
+      real ith(iip1,jjp1,nsoilmx),ithfi(ngridmx,nsoilmx) ! thermal inertia (3D)
+      real surfith(iip1,jjp1),surfithfi(ngridmx) ! surface thermal inertia (2D)
+      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
+
+      INTEGER i,j,l,isoil,ig,idum
+      real mugaz ! molar mass of the atmosphere
+
+      integer ierr 
+
+c Variables on the new grid along scalar points 
+c------------------------------------------------------
+!      REAL p(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      REAL tset(iip1,jjp1,llm)
+      real phisold_newgrid(iip1,jjp1)
+      REAL :: teta(iip1, jjp1, llm)
+      REAL :: pk(iip1,jjp1,llm)
+      REAL :: pkf(iip1,jjp1,llm)
+      REAL :: ps(iip1, jjp1)
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: beta(iip1,jjp1,llm)
+!      REAL dteta(ip1jmp1,llm)
+
+c Variable de l'ancienne grille 
+c------------------------------
+      real time
+      real tab_cntrl(100)
+      real tab_cntrl_bis(100)
+
+c variables diverses
+c-------------------
+      real choix_1,pp
+      character*80      fichnom
+      character*250  filestring
+      integer Lmodif,iq,thermo
+      character modif*20
+      real z_reel(iip1,jjp1)
+      real tsud,albsud,alb_bb,ith_bb,Tiso,Tabove
+      real ptoto,pcap,patm,airetot,ptotn,patmn,psea
+!      real ssum
+      character*1 yes
+      logical :: flagtset=.false. ,  flagps0=.false.
+      real val, val2, val3 ! to store temporary variables
+      real :: iceith=2000 ! thermal inertia of subterranean ice
+      integer iref,jref
+
+      INTEGER :: itau
+      
+      INTEGER :: nq,numvanle
+      character(len=20) :: txt ! to store some text
+      character(len=50) :: surfacefile ! "surface.nc" (or equivalent file)
+      character(len=150) :: longline
+      integer :: count
+      real :: profile(llm+1) ! to store an atmospheric profile + surface value
+
+!     added by RW for test
+      real pmean, phi0
+
+!     added by BC for equilibrium temperature startup
+      real teque
+
+!     added by BC for cloud fraction setup
+      REAL hice(ngridmx),cloudfrac(ngridmx,nlayermx)
+      REAL totalfrac(ngridmx)
+
+!     added by RW for nuketharsis
+      real fact1
+      real fact2
+
+
+c sortie visu pour les champs dynamiques
+c---------------------------------------
+!      INTEGER :: visuid
+!      real :: time_step,t_ops,t_wrt
+!      CHARACTER*80 :: visu_file
+
+      cpp    = 0.
+      preff  = 0.
+      pa     = 0. ! to ensure disaster rather than minor error if we don`t
+                  ! make deliberate choice of these values elsewhere.
+
+c=======================================================================
+c   Choice of the start file(s) to use
+c=======================================================================
+
+      write(*,*) 'From which kind of files do you want to create new',
+     .  'start and startfi files'
+      write(*,*) '    0 - from a file start_archive'
+      write(*,*) '    1 - from files start and startfi'
+ 
+c-----------------------------------------------------------------------
+c   Open file(s) to modify (start or start_archive)
+c-----------------------------------------------------------------------
+
+      DO
+         read(*,*,iostat=ierr) choix_1
+         if ((choix_1 /= 0).OR.(choix_1 /=1)) EXIT
+      ENDDO
+
+c     Open start_archive
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start_archive.nc'
+        write(*,*)
+        fichnom = 'start_archive.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+        tab0 = 50 
+        Lmodif = 1
+
+c     OR open start and startfi files
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      else
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start.nc and ./startfi.nc'
+        write(*,*)
+        fichnom = 'start.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_dyn)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+ 
+        fichnom = 'startfi.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_fi)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening file:',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+
+        tab0 = 0 
+        Lmodif = 0
+
+      endif
+
+
+c=======================================================================
+c  INITIALISATIONS DIVERSES
+c=======================================================================
+! Load tracer names:
+      call iniadvtrac(nq,numvanle)
+      ! tnom(:) now contains tracer names
+! JL12 we will need the tracer names to read start in dyneta0
+
+! Initialize global tracer indexes (stored in tracer.h)
+! ... this has to be done before phyetat0
+      call initracer(ngridmx,nqmx,tnom)
+
+! Take care of arrays in common modules
+      ! ALLOCATE ARRAYS in surfdat_h (if not already done, e.g. when using start_archive)
+      IF (.not. ALLOCATED(albedodat)) ALLOCATE(albedodat(ngridmx))
+      IF (.not. ALLOCATED(phisfi)) ALLOCATE(phisfi(ngridmx))
+      IF (.not. ALLOCATED(zmea)) ALLOCATE(zmea(ngridmx))
+      IF (.not. ALLOCATED(zstd)) ALLOCATE(zstd(ngridmx))
+      IF (.not. ALLOCATED(zsig)) ALLOCATE(zsig(ngridmx))
+      IF (.not. ALLOCATED(zgam)) ALLOCATE(zgam(ngridmx))
+      IF (.not. ALLOCATED(zthe)) ALLOCATE(zthe(ngridmx))
+      ! ALLOCATE ARRAYS in comsoil_h (if not already done)
+      IF (.not.ALLOCATED(layer))
+     . ALLOCATE(layer(nsoilmx))
+      IF (.not.ALLOCATED(mlayer))
+     . ALLOCATE(mlayer(0:nsoilmx-1))
+      IF (.not.ALLOCATED(inertiedat))
+     . ALLOCATE(inertiedat(ngridmx,nsoilmx))
+      ! ALLOCATE ARRAYS IN comgeomfi_h (done in inifis usually)
+      IF (.not. ALLOCATED(lati)) ALLOCATE(lati(ngridmx))
+      IF (.not. ALLOCATED(long)) ALLOCATE(long(ngridmx))
+      IF (.not. ALLOCATED(area)) ALLOCATE(area(ngridmx))
+      cursor = 1 ! added by AS in dimphys. 1 for sequential runs.
+
+c-----------------------------------------------------------------------
+c Lecture du tableau des parametres du run (pour la dynamique)
+c-----------------------------------------------------------------------
+
+      if (choix_1.eq.0) then
+
+        write(*,*) 'reading tab_cntrl START_ARCHIVE'
+c
+        ierr = NF_INQ_VARID (nid, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+c
+      else if (choix_1.eq.1) then
+
+        write(*,*) 'reading tab_cntrl START'
+c
+        ierr = NF_INQ_VARID (nid_dyn, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_dyn, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid_dyn, nvarid, tab_cntrl)
+#endif
+c
+        write(*,*) 'reading tab_cntrl STARTFI'
+c
+        ierr = NF_INQ_VARID (nid_fi, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_fi, nvarid, tab_cntrl_bis)
+#else
+        ierr = NF_GET_VAR_REAL(nid_fi, nvarid, tab_cntrl_bis)
+#endif
+c
+        do i=1,50
+          tab_cntrl(i+50)=tab_cntrl_bis(i)
+        enddo
+        write(*,*) 'printing tab_cntrl', tab_cntrl
+        do i=1,100
+          write(*,*) i,tab_cntrl(i)
+        enddo
+	
+        ! Lmodif set to 0 to disable modifications possibility in phyeta0                           
+        write(*,*) 'Reading file START'
+        fichnom = 'start.nc'
+        CALL dynetat0(fichnom,nqmx,vcov,ucov,teta,q,masse,
+     .       ps,phis,time)
+
+        write(*,*) 'Reading file STARTFI'
+        fichnom = 'startfi.nc'
+        CALL phyetat0 (ngridmx,fichnom,tab0,Lmodif,nsoilmx,nqmx,
+     .        day_ini,time,
+     .        tsurf,tsoil,emis,q2,qsurf,   !) ! temporary modif by RDW
+     .        cloudfrac,totalfrac,hice)
+
+        ! copy albedo and soil thermal inertia on (local) physics grid
+        do i=1,ngridmx
+          albfi(i) = albedodat(i)
+	  do j=1,nsoilmx
+           ithfi(i,j) = inertiedat(i,j)
+	  enddo
+        ! build a surfithfi(:) using 1st layer of ithfi(:), which might
+        ! be needed later on if reinitializing soil thermal inertia
+          surfithfi(i)=ithfi(i,1)
+        enddo
+        ! also copy albedo and soil thermal inertia on (local) dynamics grid
+        ! so that options below can manipulate either (but must then ensure
+        ! to correctly recast things on physics grid)
+        call gr_fi_dyn(1,ngridmx,iip1,jjp1,albfi,alb)
+        call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
+        call gr_fi_dyn(1,ngridmx,iip1,jjp1,surfithfi,surfith)
+      
+      endif
+c-----------------------------------------------------------------------
+c		Initialisation des constantes dynamique
+c-----------------------------------------------------------------------
+
+      kappa = tab_cntrl(9) 
+      etot0 = tab_cntrl(12)
+      ptot0 = tab_cntrl(13)
+      ztot0 = tab_cntrl(14)
+      stot0 = tab_cntrl(15)
+      ang0 = tab_cntrl(16)
+      write(*,*) "Newstart: kappa,etot0,ptot0,ztot0,stot0,ang0"
+      write(*,*) kappa,etot0,ptot0,ztot0,stot0,ang0
+
+      ! for vertical coordinate
+      preff=tab_cntrl(18) ! reference surface pressure
+      pa=tab_cntrl(17)  ! reference pressure at which coord is purely pressure
+      !NB: in start_archive files tab_cntrl(17)=tab_cntrl(18)=0
+      write(*,*) "Newstart: preff=",preff," pa=",pa
+      yes=' '
+      do while ((yes.ne.'y').and.(yes.ne.'n'))
+        write(*,*) "Change the values of preff and pa? (y/n)"
+        read(*,fmt='(a)') yes
+      end do
+      if (yes.eq.'y') then
+        write(*,*)"New value of reference surface pressure preff?"
+        write(*,*)"   (for Mars, typically preff=610)"
+        read(*,*) preff
+        write(*,*)"New value of reference pressure pa for purely"
+        write(*,*)"pressure levels (for hybrid coordinates)?"
+        write(*,*)"   (for Mars, typically pa=20)"
+        read(*,*) pa
+      endif
+c-----------------------------------------------------------------------
+c   Lecture du tab_cntrl et initialisation des constantes physiques
+c  - pour start:  Lmodif = 0 => pas de modifications possibles
+c                  (modif dans le tabfi de readfi + loin)
+c  - pour start_archive:  Lmodif = 1 => modifications possibles
+c-----------------------------------------------------------------------
+      if (choix_1.eq.0) then
+         call tabfi (ngridmx,nid,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+      else if (choix_1.eq.1) then
+         Lmodif=1 ! Lmodif set to 1 to allow modifications in phyeta0                           
+         call tabfi (ngridmx,nid_fi,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_cpp,p_mugaz,p_daysec,time)
+      endif
+
+      rad = p_rad
+      omeg = p_omeg
+      g = p_g
+      cpp = p_cpp
+      mugaz = p_mugaz
+      daysec = p_daysec
+
+      kappa = 8.314*1000./(p_mugaz*p_cpp) ! added by RDW
+
+c=======================================================================
+c  INITIALISATIONS DIVERSES
+c=======================================================================
+! Load parameters from run.def file
+      CALL defrun_new( 99, .TRUE. )
+      CALL iniconst 
+      CALL inigeom
+      idum=-1
+      idum=0
+
+c Initialisation coordonnees /aires
+c -------------------------------
+! Note: rlatu(:) and rlonv(:) are commons defined in "comgeom.h"
+!       rlatu() and rlonv() are given in radians
+      latfi(1)=rlatu(1)
+      lonfi(1)=0.
+      DO j=2,jjm
+         DO i=1,iim
+            latfi((j-2)*iim+1+i)=rlatu(j)
+            lonfi((j-2)*iim+1+i)=rlonv(i)
+         ENDDO
+      ENDDO
+      latfi(ngridmx)=rlatu(jjp1)
+      lonfi(ngridmx)=0.
+       
+      ! build airefi(), mesh area on physics grid
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+      ! Poles are single points on physics grid
+      airefi(1)=airefi(1)*iim
+      airefi(ngridmx)=airefi(ngridmx)*iim
+
+c=======================================================================
+c   lecture topographie, albedo, inertie thermique, relief sous-maille
+c=======================================================================
+
+      if (choix_1.eq.0) then  ! for start_archive files, 
+                              ! where an external "surface.nc" file is needed
+
+c do while((relief(1:3).ne.'mol').AND.(relief(1:3).ne.'pla'))
+c       write(*,*)
+c       write(*,*) 'choix du relief (mola,pla)'
+c       write(*,*) '(Topographie MGS MOLA, plat)'
+c       read(*,fmt='(a3)') relief
+        relief="mola"
+c     enddo
+
+!    First get the correct value of datadir, if not already done:
+        ! default 'datadir' is set in "datafile_mod"
+        call getin("datadir",datadir)
+        write(*,*) 'Available surface data files are:'
+        filestring='ls '//trim(datadir)//' | grep .nc'
+        call system(filestring)
+
+        write(*,*) ''
+        write(*,*) 'Please choose the relevant file',
+     &  ' (e.g. "surface_mars.nc")'
+        write(*,*) ' or "none" to not use any (and set planetary'
+        write(*,*) '  albedo and surface thermal inertia)'
+        read(*,fmt='(a50)') surfacefile
+
+        if (surfacefile.ne."none") then
+
+          CALL datareadnc(relief,surfacefile,phis,alb,surfith,
+     &          zmeaS,zstdS,zsigS,zgamS,ztheS)
+        else
+        ! specific case when not using a "surface.nc" file
+          phis(:,:)=0
+          zmeaS(:,:)=0
+          zstdS(:,:)=0
+          zsigS(:,:)=0
+          zgamS(:,:)=0
+          ztheS(:,:)=0
+          
+          write(*,*) "Enter value of albedo of the bare ground:"
+          read(*,*) alb(1,1)
+          alb(:,:)=alb(1,1)
+          
+          write(*,*) "Enter value of thermal inertia of soil:"
+          read(*,*) surfith(1,1)
+          surfith(:,:)=surfith(1,1)
+        
+        endif ! of if (surfacefile.ne."none")
+
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,surfith,surfithfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zmeaS,zmea)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zstdS,zstd)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zsigS,zsig)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zgamS,zgam)
+        CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ztheS,zthe)
+
+      endif ! of if (choix_1.eq.0)
+
+
+c=======================================================================
+c  Lecture des fichiers (start ou start_archive)
+c=======================================================================
+
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Reading file START_ARCHIVE'
+        CALL lect_start_archive(date,tsurf,tsoil,emis,q2,
+     .   t,ucov,vcov,ps,teta,phisold_newgrid,q,qsurf,
+     &   surfith,nid)
+        write(*,*) "OK, read start_archive file"
+	! copy soil thermal inertia
+	ithfi(:,:)=inertiedat(:,:)
+	
+        ierr= NF_CLOSE(nid)
+
+      else if (choix_1.eq.1) then 
+         !do nothing, start and startfi have already been read
+      else 
+        CALL exit(1)
+      endif
+
+      dtvr   = daysec/FLOAT(day_step)
+      dtphys   = dtvr * FLOAT(iphysiq)
+
+c=======================================================================
+c 
+c=======================================================================
+
+      do ! infinite loop on list of changes
+
+      write(*,*)
+      write(*,*)
+      write(*,*) 'List of possible changes :'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      write(*,*)
+      write(*,*) 'flat : no topography ("aquaplanet")'
+      write(*,*) 'nuketharsis : no Tharsis bulge'
+      write(*,*) 'bilball : uniform albedo and thermal inertia'
+      write(*,*) 'coldspole : cold subsurface and high albedo at S.pole'
+      write(*,*) 'qname : change tracer name'
+      write(*,*) 'q=0 : ALL tracer =zero'
+      write(*,*) 'q=x : give a specific uniform value to one tracer'
+      write(*,*) 'q=profile    : specify a profile for a tracer'
+!      write(*,*) 'ini_q : tracers initialisation for chemistry, water an
+!     $d ice   '
+!      write(*,*) 'ini_q-H2O : tracers initialisation for chemistry and 
+!     $ice '
+!      write(*,*) 'ini_q-iceH2O : tracers initialisation for chemistry on
+!     $ly '
+      write(*,*) 'noglacier : Remove tropical H2O ice if |lat|<45'
+      write(*,*) 'watercapn : H20 ice on permanent N polar cap '
+      write(*,*) 'watercaps : H20 ice on permanent S polar cap '
+      write(*,*) 'noacglac  : H2O ice across Noachis Terra'
+      write(*,*) 'oborealis : H2O ice across Vastitas Borealis'
+      write(*,*) 'iceball   : Thick ice layer all over surface'
+      write(*,*) 'wetstart  : start with a wet atmosphere'
+      write(*,*) 'isotherm  : Isothermal Temperatures, wind set to zero'
+      write(*,*) 'radequi   : Earth-like radiative equilibrium temperature
+     $ profile (lat-alt) and winds set to zero'
+      write(*,*) 'coldstart : Start X K above the CO2 frost point and 
+     $set wind to zero (assumes 100% CO2)'
+      write(*,*) 'co2ice=0 : remove CO2 polar cap'
+      write(*,*) 'ptot : change total pressure'
+      write(*,*) 'emis : change surface emissivity'
+      write(*,*) 'therm_ini_s : Set soil thermal inertia to reference sur
+     &face values'
+
+        write(*,*)
+        write(*,*) 'Change to perform ?'
+        write(*,*) '   (enter keyword or return to end)'
+        write(*,*)
+
+        read(*,fmt='(a20)') modif
+        if (modif(1:1) .eq. ' ') exit ! exit loop on changes
+
+        write(*,*)
+        write(*,*) trim(modif) , ' : '
+
+c       'flat : no topography ("aquaplanet")'
+c       -------------------------------------
+        if (trim(modif) .eq. 'flat') then
+c         set topo to zero 
+          z_reel(1:iip1,1:jjp1)=0
+          phis(1:iip1,1:jjp1)=g*z_reel(1:iip1,1:jjp1)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+          write(*,*) 'topography set to zero.'
+          write(*,*) 'WARNING : the subgrid topography parameters',
+     &    ' were not set to zero ! => set calllott to F'                    
+
+c        Choice of surface pressure
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to choose homogeneous surface',
+     &                 'pressure (y) or let newstart interpolate ',
+     &                 ' the previous field  (n)?'
+             read(*,fmt='(a)') yes
+         end do
+         if (yes.eq.'y') then
+           flagps0=.true.
+           write(*,*) 'New value for ps (Pa) ?'
+ 201       read(*,*,iostat=ierr) patm
+            if(ierr.ne.0) goto 201
+             write(*,*)
+             write(*,*) ' new ps everywhere (Pa) = ', patm
+             write(*,*)
+             do j=1,jjp1
+               do i=1,iip1
+                 ps(i,j)=patm
+               enddo
+             enddo
+         end if
+
+c       'nuketharsis : no tharsis bulge for Early Mars'
+c       ---------------------------------------------
+        else if (trim(modif) .eq. 'nuketharsis') then
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 fact1=(((rlonv(i)*180./pi)+100)**2 + 
+     &                (rlatu(j)*180./pi)**2)/65**2 
+                 fact2=exp( -fact1**2.5 )
+
+                 phis(i,j) = phis(i,j) - (phis(i,j)+4000.*g)*fact2
+
+!                 if(phis(i,j).gt.2500.*g)then
+!                    if(rlatu(j)*180./pi.gt.-80.)then ! avoid chopping south polar cap
+!                       phis(i,j)=2500.*g
+!                    endif
+!                 endif
+
+              ENDDO
+           ENDDO
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+c       bilball : uniform albedo, thermal inertia
+c       -----------------------------------------
+        else if (trim(modif) .eq. 'bilball') then
+          write(*,*) 'constante albedo and iner.therm:'
+          write(*,*) 'New value for albedo (ex: 0.25) ?'
+ 101      read(*,*,iostat=ierr) alb_bb
+          if(ierr.ne.0) goto 101
+          write(*,*)
+          write(*,*) ' uniform albedo (new value):',alb_bb
+          write(*,*)
+
+          write(*,*) 'New value for thermal inertia (eg: 247) ?'
+ 102      read(*,*,iostat=ierr) ith_bb
+          if(ierr.ne.0) goto 102
+          write(*,*) 'uniform thermal inertia (new value):',ith_bb
+          DO j=1,jjp1
+             DO i=1,iip1
+                alb(i,j) = alb_bb	! albedo
+		do isoil=1,nsoilmx
+                  ith(i,j,isoil) = ith_bb	! thermal inertia
+		enddo
+             END DO
+          END DO
+!          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+c       coldspole : sous-sol de la calotte sud toujours froid
+c       -----------------------------------------------------
+        else if (trim(modif) .eq. 'coldspole') then
+          write(*,*)'new value for the subsurface temperature',
+     &   ' beneath the permanent southern polar cap ? (eg: 141 K)'
+ 103      read(*,*,iostat=ierr) tsud
+          if(ierr.ne.0) goto 103
+          write(*,*)
+          write(*,*) ' new value of the subsurface temperature:',tsud
+c         nouvelle temperature sous la calotte permanente
+          do l=2,nsoilmx
+               tsoil(ngridmx,l) =  tsud
+          end do
+
+
+          write(*,*)'new value for the albedo',
+     &   'of the permanent southern polar cap ? (eg: 0.75)'
+ 104      read(*,*,iostat=ierr) albsud
+          if(ierr.ne.0) goto 104
+          write(*,*)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c         Option 1:  only the albedo of the pole is modified :    
+          albfi(ngridmx)=albsud
+          write(*,*) 'ig=',ngridmx,'   albedo perennial cap ',
+     &    albfi(ngridmx)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+c          Option 2 A haute resolution : coordonnee de la vrai calotte ~    
+c           DO j=1,jjp1
+c             DO i=1,iip1
+c                ig=1+(j-2)*iim +i
+c                if(j.eq.1) ig=1
+c                if(j.eq.jjp1) ig=ngridmx
+c                if ((rlatu(j)*180./pi.lt.-84.).and.
+c     &            (rlatu(j)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.lt.0.))         then
+cc    albedo de la calotte permanente fixe a albsud
+c                   alb(i,j)=albsud
+c                   write(*,*) 'lat=',rlatu(j)*180./pi,
+c     &                      ' lon=',rlonv(i)*180./pi
+cc     fin de la condition sur les limites de la calotte permanente
+c                end if
+c             ENDDO
+c          ENDDO
+c      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+c         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+
+c       ptot : Modification of the total pressure: ice + current atmosphere 
+c       -------------------------------------------------------------------
+        else if (trim(modif).eq.'ptot') then
+
+          ! check if we have a co2_ice surface tracer:
+          if (igcm_co2_ice.eq.0) then
+            write(*,*) " No surface CO2 ice !"
+            write(*,*) " only atmospheric pressure will be considered!"
+          endif
+c         calcul de la pression totale glace + atm actuelle
+          patm=0.
+          airetot=0.
+          pcap=0.
+          DO j=1,jjp1
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+                patm = patm + ps(i,j)*aire(i,j)
+                airetot= airetot + aire(i,j)
+                if (igcm_co2_ice.ne.0) then
+                  !pcap = pcap + aire(i,j)*co2ice(ig)*g
+                  pcap = pcap + aire(i,j)*qsurf(ig,igcm_co2_ice)*g
+                endif
+             ENDDO
+          ENDDO
+          ptoto = pcap + patm
+
+          print*,'Current total pressure at surface (co2 ice + atm) ',
+     &       ptoto/airetot
+
+          print*,'new value?'
+          read(*,*) ptotn
+          ptotn=ptotn*airetot
+          patmn=ptotn-pcap
+          print*,'ptoto,patm,ptotn,patmn'
+          print*,ptoto,patm,ptotn,patmn
+          print*,'Mult. factor for pressure (atm only)', patmn/patm
+          do j=1,jjp1
+             do i=1,iip1
+                ps(i,j)=ps(i,j)*patmn/patm
+             enddo
+          enddo
+
+
+
+c        Correction pour la conservation des traceurs
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to conserve tracer total mass (y)',
+     &              ' or tracer mixing ratio (n) ?'
+             read(*,fmt='(a)') yes
+         end do
+
+         if (yes.eq.'y') then
+           write(*,*) 'OK : conservation of tracer total mass'
+           DO iq =1, nqmx
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=q(i,j,l,iq)*patm/patmn
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+          else
+            write(*,*) 'OK : conservation of tracer mixing ratio'
+          end if
+
+c        Correction pour la pression au niveau de la mer
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish fix pressure at sea level (y)',
+     &              ' or not (n) ?'
+             read(*,fmt='(a)') yes
+         end do
+
+         if (yes.eq.'y') then
+           write(*,*) 'Value?'
+		read(*,*,iostat=ierr) psea
+             DO i=1,iip1
+               DO j=1,jjp1
+                    ps(i,j)=psea
+
+                  ENDDO
+               ENDDO
+		write(*,*) 'psea=',psea
+          else
+            write(*,*) 'no'
+          end if
+
+
+c       emis : change surface emissivity (added by RW)
+c       ----------------------------------------------
+        else if (trim(modif).eq.'emis') then
+
+           print*,'new value?'
+           read(*,*) emisread
+
+           do i=1,ngridmx
+              emis(i)=emisread
+           enddo
+
+c       qname : change tracer name
+c       --------------------------
+        else if (trim(modif).eq.'qname') then
+         yes='y'
+         do while (yes.eq.'y')
+          write(*,*) 'Which tracer name do you want to change ?'
+          do iq=1,nqmx
+            write(*,'(i3,a3,a20)')iq,' : ',trim(tnom(iq))
+          enddo
+          write(*,'(a35,i3)')
+     &            '(enter tracer number; between 1 and ',nqmx
+          write(*,*)' or any other value to quit this option)'
+          read(*,*) iq
+          if ((iq.ge.1).and.(iq.le.nqmx)) then
+            write(*,*)'Change tracer name ',trim(tnom(iq)),' to ?'
+            read(*,*) txt
+            tnom(iq)=txt
+            write(*,*)'Do you want to change another tracer name (y/n)?'
+            read(*,'(a)') yes 
+          else
+! inapropiate value of iq; quit this option
+            yes='n'
+          endif ! of if ((iq.ge.1).and.(iq.le.nqmx))
+         enddo ! of do while (yes.ne.'y')
+
+c       q=0 : set tracers to zero
+c       -------------------------
+        else if (trim(modif).eq.'q=0') then
+c          mise a 0 des q (traceurs)
+          write(*,*) 'Tracers set to 0 (1.E-30 in fact)'
+           DO iq =1, nqmx
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=1.e-30
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+
+c          set surface tracers to zero
+           DO iq =1, nqmx
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=0.
+             ENDDO
+           ENDDO
+
+c       q=x : initialise tracer manually 
+c       --------------------------------
+        else if (trim(modif).eq.'q=x') then
+             write(*,*) 'Which tracer do you want to modify ?'
+             do iq=1,nqmx
+               write(*,*)iq,' : ',trim(tnom(iq))
+             enddo
+             write(*,*) '(choose between 1 and ',nqmx,')'
+             read(*,*) iq 
+             write(*,*)'mixing ratio of tracer ',trim(tnom(iq)),
+     &                 ' ? (kg/kg)'
+             read(*,*) val
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=val
+                  ENDDO
+               ENDDO
+             ENDDO
+             write(*,*) 'SURFACE value of tracer ',trim(tnom(iq)),
+     &                   ' ? (kg/m2)'
+             read(*,*) val
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=val
+             ENDDO
+
+c       q=profile : initialize tracer with a given profile
+c       --------------------------------------------------
+        else if (trim(modif) .eq. 'q=profile') then
+             write(*,*) 'Tracer profile will be sought in ASCII file'
+             write(*,*) "'profile_tracer' where 'tracer' is tracer name"
+             write(*,*) "(one value per line in file; starting with"
+             write(*,*) "surface value, the 1st atmospheric layer"
+             write(*,*) "followed by 2nd, etc. up to top of atmosphere)"
+             write(*,*) 'Which tracer do you want to set?'
+             do iq=1,nqmx
+               write(*,*)iq,' : ',trim(tnom(iq))
+             enddo
+             write(*,*) '(choose between 1 and ',nqmx,')'
+             read(*,*) iq 
+             if ((iq.lt.1).or.(iq.gt.nqmx)) then
+               ! wrong value for iq, go back to menu
+               write(*,*) "wrong input value:",iq
+               cycle
+             endif
+             ! look for input file 'profile_tracer'
+             txt="profile_"//trim(tnom(iq))
+             open(41,file=trim(txt),status='old',form='formatted',
+     &            iostat=ierr)
+             if (ierr.eq.0) then
+               ! OK, found file 'profile_...', load the profile
+               do l=1,llm+1
+                 read(41,*,iostat=ierr) profile(l)
+                 if (ierr.ne.0) then ! something went wrong
+                   exit ! quit loop
+                 endif
+               enddo
+               if (ierr.eq.0) then
+                 ! initialize tracer values
+                 qsurf(:,iq)=profile(1)
+                 do l=1,llm
+                   q(:,:,l,iq)=profile(l+1)
+                 enddo
+                 write(*,*)'OK, tracer ',trim(tnom(iq)),' initialized ',
+     &                     'using values from file ',trim(txt)
+               else
+                 write(*,*)'problem reading file ',trim(txt),' !'
+                 write(*,*)'No modifications to tracer ',trim(tnom(iq))
+               endif
+             else
+               write(*,*)'Could not find file ',trim(txt),' !'
+               write(*,*)'No modifications to tracer ',trim(tnom(iq))
+             endif
+             
+
+c      wetstart : wet atmosphere with a north to south gradient
+c      --------------------------------------------------------
+       else if (trim(modif) .eq. 'wetstart') then
+        ! check that there is indeed a water vapor tracer
+        if (igcm_h2o_vap.eq.0) then
+          write(*,*) "No water vapour tracer! Can't use this option"
+          stop
+        endif
+          DO l=1,llm
+            DO j=1,jjp1
+              DO i=1,iip1
+                q(i,j,l,igcm_h2o_vap)=150.e-6 * (rlatu(j)+pi/2.) / pi
+              ENDDO
+            ENDDO
+          ENDDO
+
+         write(*,*) 'Water mass mixing ratio at north pole='
+     *               ,q(1,1,1,igcm_h2o_vap)
+         write(*,*) '---------------------------south pole='
+     *               ,q(1,jjp1,1,igcm_h2o_vap)
+
+c      noglacier : remove tropical water ice (to initialize high res sim)
+c      --------------------------------------------------
+        else if (trim(modif) .eq. 'noglacier') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+           do ig=1,ngridmx
+             j=(ig-2)/iim +2
+              if(ig.eq.1) j=1
+              write(*,*) 'OK: remove surface ice for |lat|<45'
+              if (abs(rlatu(j)*180./pi).lt.45.) then
+                   qsurf(ig,igcm_h2o_ice)=0.
+              end if
+           end do
+
+
+c      watercapn : H20 ice on permanent northern cap
+c      --------------------------------------------------
+        else if (trim(modif) .eq. 'watercapn') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 if (rlatu(j)*180./pi.gt.80.) then
+                    qsurf(ig,igcm_h2o_ice)=3.4e3
+                    !do isoil=1,nsoilmx
+                    !   ith(i,j,isoil) = 18000. ! thermal inertia
+                    !enddo
+                   write(*,*)'     ==> Ice mesh North boundary (deg)= ',
+     &                   rlatv(j-1)*180./pi
+                 end if
+              ENDDO
+           ENDDO
+           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+
+c$$$           do ig=1,ngridmx
+c$$$             j=(ig-2)/iim +2
+c$$$              if(ig.eq.1) j=1
+c$$$              if (rlatu(j)*180./pi.gt.80.) then
+c$$$
+c$$$                   qsurf(ig,igcm_h2o_ice)=1.e5
+c$$$                   qsurf(ig,igcm_h2o_vap)=0.0!1.e5
+c$$$
+c$$$                   write(*,*) 'ig=',ig,'    H2O ice mass (kg/m2)= ',
+c$$$     &              qsurf(ig,igcm_h2o_ice)
+c$$$
+c$$$                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
+c$$$     &              rlatv(j)*180./pi
+c$$$                end if
+c$$$           enddo
+
+c      watercaps : H20 ice on permanent southern cap
+c      -------------------------------------------------
+        else if (trim(modif) .eq. 'watercaps') then
+           if (igcm_h2o_ice.eq.0) then
+              write(*,*) "No water ice tracer! Can't use this option"
+              stop
+           endif
+
+           DO j=1,jjp1        
+              DO i=1,iim
+                 ig=1+(j-2)*iim +i
+                 if(j.eq.1) ig=1
+                 if(j.eq.jjp1) ig=ngridmx
+
+                 if (rlatu(j)*180./pi.lt.-80.) then
+                    qsurf(ig,igcm_h2o_ice)=3.4e3
+                    !do isoil=1,nsoilmx
+                    !   ith(i,j,isoil) = 18000. ! thermal inertia
+                    !enddo
+                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
+     &                   rlatv(j-1)*180./pi
+                 end if
+              ENDDO
+           ENDDO
+           CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+
+c$$$           do ig=1,ngridmx
+c$$$               j=(ig-2)/iim +2
+c$$$               if(ig.eq.1) j=1
+c$$$               if (rlatu(j)*180./pi.lt.-80.) then
+c$$$                  qsurf(ig,igcm_h2o_ice)=1.e5
+c$$$                  qsurf(ig,igcm_h2o_vap)=0.0 !1.e5
+c$$$
+c$$$                  write(*,*) 'ig=',ig,'   H2O ice mass (kg/m2)= ',
+c$$$     &                 qsurf(ig,igcm_h2o_ice)
+c$$$                  write(*,*)'     ==> Ice mesh North boundary (deg)= ',
+c$$$     &                 rlatv(j-1)*180./pi
+c$$$               end if
+c$$$           enddo
+
+
+c       noacglac : H2O ice across highest terrain
+c       --------------------------------------------
+        else if (trim(modif) .eq. 'noacglac') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).gt.1000.*g)then
+                    alb(i,j) = 0.5 ! snow value
+                    do isoil=1,nsoilmx
+                       ith(i,j,isoil) = 18000. ! thermal inertia
+                       ! this leads to rnat set to 'ocean' in physiq.F90
+                       ! actually no, because it is soil not surface
+                    enddo
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+
+c       oborealis : H2O oceans across Vastitas Borealis
+c       -----------------------------------------------
+        else if (trim(modif) .eq. 'oborealis') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).lt.-4000.*g)then
+!                if( (phis(i,j).lt.-4000.*g)
+!     &               .and. (rlatu(j)*180./pi.lt.0.) )then ! south hemisphere only
+!                    phis(i,j)=-8000.0*g ! proper ocean
+                    phis(i,j)=-4000.0*g ! scanty ocean
+
+                    alb(i,j) = 0.07 ! oceanic value
+                    do isoil=1,nsoilmx
+                       ith(i,j,isoil) = 18000. ! thermal inertia
+                       ! this leads to rnat set to 'ocean' in physiq.F90
+                       ! actually no, because it is soil not surface
+                    enddo
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+c       iborealis : H2O ice in Northern plains
+c       --------------------------------------
+        else if (trim(modif) .eq. 'iborealis') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                if(phis(i,j).lt.-4000.*g)then
+                   !qsurf(ig,igcm_h2o_ice)=1.e3
+                   qsurf(ig,igcm_h2o_ice)=241.4 ! to make total 33 kg m^-2
+                endif
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+
+c       oceanball : H2O liquid everywhere
+c       ----------------------------
+        else if (trim(modif) .eq. 'oceanball') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                qsurf(ig,igcm_h2o_vap)=0.0    ! for ocean, this is infinite source
+                qsurf(ig,igcm_h2o_ice)=0.0
+                alb(i,j) = 0.07 ! ocean value
+
+                do isoil=1,nsoilmx
+                   ith(i,j,isoil) = 18000. ! thermal inertia
+                   !ith(i,j,isoil) = 50. ! extremely low for test
+                   ! this leads to rnat set to 'ocean' in physiq.F90
+                enddo
+
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+
+c       iceball : H2O ice everywhere
+c       ----------------------------
+        else if (trim(modif) .eq. 'iceball') then
+           if (igcm_h2o_ice.eq.0) then
+             write(*,*) "No water ice tracer! Can't use this option"
+             stop
+           endif
+          DO j=1,jjp1        
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+
+                qsurf(ig,igcm_h2o_vap)=-50.    ! for ocean, this is infinite source
+                qsurf(ig,igcm_h2o_ice)=50.     ! == to 0.05 m of oceanic ice
+                alb(i,j) = 0.6 ! ice albedo value
+
+                do isoil=1,nsoilmx
+                   !ith(i,j,isoil) = 18000. ! thermal inertia
+                   ! this leads to rnat set to 'ocean' in physiq.F90
+                enddo
+
+             ENDDO
+          ENDDO
+          CALL gr_dyn_fi(nsoilmx,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+c       isotherm : Isothermal temperatures and no winds
+c       -----------------------------------------------
+        else if (trim(modif) .eq. 'isotherm') then
+
+          write(*,*)'Isothermal temperature of the atmosphere, 
+     &           surface and subsurface'
+          write(*,*) 'Value of this temperature ? :'
+ 203      read(*,*,iostat=ierr) Tiso
+          if(ierr.ne.0) goto 203
+
+          tsurf(1:ngridmx)=Tiso
+          
+          tsoil(1:ngridmx,1:nsoilmx)=Tiso
+          
+          Tset(1:iip1,1:jjp1,1:llm)=Tiso
+          flagtset=.true.
+          
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+c       radequi : Radiative equilibrium profile of temperatures and no winds
+c       --------------------------------------------------------------------
+        else if (trim(modif) .eq. 'radequi') then
+
+          write(*,*)'radiative equilibrium temperature profile'       
+
+          do ig=1, ngridmx
+             teque= 335.0-60.0*sin(latfi(ig))*sin(latfi(ig))-
+     &            10.0*cos(latfi(ig))*cos(latfi(ig))
+             tsurf(ig) = MAX(220.0,teque)
+          end do
+          do l=2,nsoilmx
+             do ig=1, ngridmx
+                tsoil(ig,l) = tsurf(ig)
+             end do
+          end do
+          DO j=1,jjp1
+             DO i=1,iim
+                Do l=1,llm
+                   teque=335.-60.0*sin(rlatu(j))*sin(rlatu(j))-
+     &                  10.0*cos(rlatu(j))*cos(rlatu(j))
+                   Tset(i,j,l)=MAX(220.0,teque)
+                end do
+             end do
+          end do
+          flagtset=.true.
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+c       coldstart : T set 1K above CO2 frost point and no winds
+c       ------------------------------------------------
+        else if (trim(modif) .eq. 'coldstart') then
+
+          write(*,*)'set temperature of the atmosphere,' 
+     &,'surface and subsurface how many degrees above CO2 frost point?'
+ 204      read(*,*,iostat=ierr) Tabove
+          if(ierr.ne.0) goto 204
+
+            DO j=1,jjp1
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+            tsurf(ig) = (-3167.8)/(log(.01*ps(i,j))-23.23)+Tabove
+             END DO
+            END DO
+          do l=1,nsoilmx
+            do ig=1, ngridmx
+              tsoil(ig,l) = tsurf(ig)
+            end do
+          end do
+          DO j=1,jjp1
+           DO i=1,iim
+            Do l=1,llm
+               pp = aps(l) +bps(l)*ps(i,j) 
+               Tset(i,j,l)=(-3167.8)/(log(.01*pp)-23.23)+Tabove
+            end do
+           end do
+          end do
+
+          flagtset=.true.
+          ucov(1:iip1,1:jjp1,1:llm)=0
+          vcov(1:iip1,1:jjm,1:llm)=0
+          q2(1:ngridmx,1:nlayermx+1)=0
+
+
+c       co2ice=0 : remove CO2 polar ice caps'
+c       ------------------------------------------------
+        else if (trim(modif) .eq. 'co2ice=0') then
+         ! check that there is indeed a co2_ice tracer ...
+          if (igcm_co2_ice.ne.0) then
+           do ig=1,ngridmx
+              !co2ice(ig)=0
+              qsurf(ig,igcm_co2_ice)=0
+              emis(ig)=emis(ngridmx/2)
+           end do
+          else
+            write(*,*) "Can't remove CO2 ice!! (no co2_ice tracer)"
+          endif
+        
+!       therm_ini_s: (re)-set soil thermal inertia to reference surface values
+!       ----------------------------------------------------------------------
+
+	else if (trim(modif).eq.'therm_ini_s') then
+!          write(*,*)"surfithfi(1):",surfithfi(1)
+	  do isoil=1,nsoilmx
+	    inertiedat(1:ngridmx,isoil)=surfithfi(1:ngridmx)
+	  enddo
+          write(*,*)'OK: Soil thermal inertia has been reset to referenc
+     &e surface values'
+!	  write(*,*)"inertiedat(1,1):",inertiedat(1,1)
+	  ithfi(:,:)=inertiedat(:,:)
+	 ! recast ithfi() onto ith()
+	 call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,ithfi,ith)
+! Check:
+!         do i=1,iip1
+!           do j=1,jjp1
+!             do isoil=1,nsoilmx
+!               write(77,*) i,j,isoil,"  ",ith(i,j,isoil)
+!             enddo
+!           enddo
+!	 enddo
+
+
+        else
+          write(*,*) '       Unknown (misspelled?) option!!!'
+        end if ! of if (trim(modif) .eq. '...') elseif ...
+	
+
+
+
+
+
+
+
+
+
+
+       enddo ! of do ! infinite loop on liste of changes
+
+ 999  continue
+
+ 
+c=======================================================================
+c   Initialisation for cloud fraction and oceanic ice (added by BC 2010)
+c=======================================================================
+      DO ig=1, ngridmx
+         totalfrac(ig)=0.5
+         DO l=1,llm
+            cloudfrac(ig,l)=0.5
+         ENDDO
+! Ehouarn, march 2012: also add some initialisation for hice
+         hice(ig)=0.0
+      ENDDO
+      
+c========================================================
+
+!      DO ig=1,ngridmx
+!         IF(tsurf(ig) .LT. 273.16-1.8) THEN
+!            hice(ig)=(273.16-1.8-tsurf(ig))/(273.16-1.8-240)*1.
+!            hice(ig)=min(hice(ig),1.0)
+!         ENDIF
+!      ENDDO
+
+c=======================================================================
+c   Correct pressure on the new grid (menu 0)
+c=======================================================================
+
+
+      if ((choix_1.eq.0).and.(.not.flagps0)) then
+        r = 1000.*8.31/mugaz
+
+        do j=1,jjp1
+          do i=1,iip1
+             ps(i,j) = ps(i,j) *
+     .            exp((phisold_newgrid(i,j)-phis(i,j)) /
+     .                                  (t(i,j,1) * r))
+          end do
+        end do
+
+c periodicite de ps en longitude
+        do j=1,jjp1
+          ps(1,j) = ps(iip1,j)
+        end do
+      end if
+
+         
+c=======================================================================
+c=======================================================================
+
+c=======================================================================
+c    Initialisation de la physique / ecriture de newstartfi :
+c=======================================================================
+
+
+      CALL inifilr 
+      CALL pression(ip1jmp1, ap, bp, ps, p3d)
+
+c-----------------------------------------------------------------------
+c   Initialisation  pks:
+c-----------------------------------------------------------------------
+
+      CALL exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
+! Calcul de la temperature potentielle teta
+
+      if (flagtset) then
+          DO l=1,llm
+             DO j=1,jjp1
+                DO i=1,iim
+                   teta(i,j,l) = Tset(i,j,l) * cpp/pk(i,j,l)
+                ENDDO
+                teta (iip1,j,l)= teta (1,j,l)
+             ENDDO
+          ENDDO
+      else if (choix_1.eq.0) then
+         DO l=1,llm
+            DO j=1,jjp1
+               DO i=1,iim
+                  teta(i,j,l) = t(i,j,l) * cpp/pk(i,j,l)
+               ENDDO
+               teta (iip1,j,l)= teta (1,j,l)
+            ENDDO
+         ENDDO
+      endif
+
+C Calcul intermediaire
+c
+      if (choix_1.eq.0) then
+         CALL massdair( p3d, masse  )
+c
+         print *,' ALPHAX ',alphax
+
+         DO  l = 1, llm
+           DO  i    = 1, iim
+             xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+             xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+           ENDDO
+             xpn      = SUM(xppn)/apoln
+             xps      = SUM(xpps)/apols
+           DO i   = 1, iip1
+             masse(   i   ,   1     ,  l )   = xpn
+             masse(   i   ,   jjp1  ,  l )   = xps
+           ENDDO
+         ENDDO
+      endif
+      phis(iip1,:) = phis(1,:)
+
+      CALL inidissip ( lstardis, nitergdiv, nitergrot, niterh,
+     *                tetagdiv, tetagrot , tetatemp  )
+      itau=0
+      if (choix_1.eq.0) then
+         day_ini=int(date)
+      endif
+c
+      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      CALL caldyn0( itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,day_ini+time )
+
+          
+      CALL dynredem0("restart.nc",day_ini,anneeref,phis,nqmx)
+      CALL dynredem1("restart.nc",0.0,vcov,ucov,teta,q,nqmx,masse,ps) 
+C
+C Ecriture etat initial physique
+C
+
+!      do ig=1,ngridmx
+!         print*,'surface ice in newstart=',qsurf(ig,igcm_h2o_ice)
+!         print*,'surface liq in newstart=',qsurf(ig,igcm_h2o_vap)
+!      enddo
+!      stop
+
+
+      call physdem1(ngridmx,"restartfi.nc",lonfi,latfi,nsoilmx,nqmx,
+     .              dtphys,float(day_ini),
+     .              time,tsurf,tsoil,emis,q2,qsurf,
+     .              airefi,albfi,ithfi,zmea,zstd,zsig,zgam,zthe,
+     .              cloudfrac,totalfrac,hice,tnom)
+
+c=======================================================================
+c	Formats 
+c=======================================================================
+
+   1  FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lllm =',i4,2x,'lue sur le fichier demar
+     *rage est differente de la valeur parametree llm =',i4//)
+
+      end
+
Index: trunk/LMDZ.GENERIC/makegcm_g95
===================================================================
--- trunk/LMDZ.GENERIC/makegcm_g95	(revision 987)
+++ trunk/LMDZ.GENERIC/makegcm_g95	(revision 988)
@@ -560,5 +560,5 @@
 if ( $dimension == 1 ) then
   echo pas de dynamique
-  set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+  set dyn="L_DYN= DYN= L_FILTRE= "
 endif
 endif
@@ -724,6 +724,11 @@
 
 set source_code=${code}.F
-if (-f $LMDGCM/libf/phystd/${code}.F90) then
+# handle cases when the main program is in the physics directory
+if (-f $LMDGCM/libf/phy${physique}/${code}.F) then
+  set dyn="$dyn DIRMAIN=phy$physique "
+endif
+if (-f $LMDGCM/libf/phy${physique}/${code}.F90) then
   set source_code=${code}.F90
+  set dyn="$dyn DIRMAIN=phy$physique "
 endif
 
Index: trunk/LMDZ.GENERIC/makegcm_gfortran
===================================================================
--- trunk/LMDZ.GENERIC/makegcm_gfortran	(revision 987)
+++ trunk/LMDZ.GENERIC/makegcm_gfortran	(revision 988)
@@ -565,5 +565,5 @@
 if ( $dimension == 1 ) then
   echo pas de dynamique
-  set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+  set dyn="L_DYN= DYN= L_FILTRE= "
 endif
 endif
@@ -735,6 +735,11 @@
 
 set source_code=${code}.F
-if (-f $LMDGCM/libf/phystd/${code}.F90) then
+# handle cases when the main program is in the physics directory
+if (-f $LMDGCM/libf/phy${physique}/${code}.F) then
+  set dyn="$dyn DIRMAIN=phy$physique "
+endif
+if (-f $LMDGCM/libf/phy${physique}/${code}.F90) then
   set source_code=${code}.F90
+  set dyn="$dyn DIRMAIN=phy$physique "
 endif
 
Index: trunk/LMDZ.GENERIC/makegcm_ifort
===================================================================
--- trunk/LMDZ.GENERIC/makegcm_ifort	(revision 987)
+++ trunk/LMDZ.GENERIC/makegcm_ifort	(revision 988)
@@ -567,5 +567,5 @@
 if ( $dimension == 1 ) then
   echo pas de dynamique
-  set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+  set dyn="L_DYN= DYN= L_FILTRE= "
 endif
 endif
@@ -736,6 +736,11 @@
 
 set source_code=${code}.F
-if (-f $LMDGCM/libf/phystd/${code}.F90) then
+# handle cases when the main program is in the physics directory
+if (-f $LMDGCM/libf/phy${physique}/${code}.F) then
+  set dyn="$dyn DIRMAIN=phy$physique "
+endif
+if (-f $LMDGCM/libf/phy${physique}/${code}.F90) then
   set source_code=${code}.F90
+  set dyn="$dyn DIRMAIN=phy$physique "
 endif
 
Index: trunk/LMDZ.GENERIC/makegcm_pgf90
===================================================================
--- trunk/LMDZ.GENERIC/makegcm_pgf90	(revision 987)
+++ trunk/LMDZ.GENERIC/makegcm_pgf90	(revision 988)
@@ -562,5 +562,5 @@
 if ( $dimension == 1 ) then
   echo pas de dynamique
-  set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+  set dyn="L_DYN= DYN= L_FILTRE= "
 endif
 endif
@@ -732,6 +732,11 @@
 
 set source_code=${code}.F
-if (-f $LMDGCM/libf/phystd/${code}.F90) then
+# handle cases when the main program is in the physics directory
+if (-f $LMDGCM/libf/phy${physique}/${code}.F) then
+  set dyn="$dyn DIRMAIN=phy$physique "
+endif
+if (-f $LMDGCM/libf/phy${physique}/${code}.F90) then
   set source_code=${code}.F90
+  set dyn="$dyn DIRMAIN=phy$physique "
 endif
 
