--- trunk/libf/bibio/writehist.f	2012/01/10 19:02:02	56
+++ trunk/dyn3d/writehist.f	2018/03/20 09:35:59	265
@@ -1,117 +1,73 @@
-!
-! $Id: writehist.F 1403 2010-07-01 09:02:53Z fairhead $
-!
-      subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
-
-      use dimens_m, only: nqmx, llm, jjm
-      USE iniadvtrac_m, ONLY: ttext
-      use com_io_dyn, only: histid,histvid,histuid
-      use paramet_m, only: ip1jm, ip1jmp1, iip1, jjp1
-      use temps, only: itau_dyn
-      use histwrite_m, only: histwrite
-      use histcom, only: histsync
-
-      implicit none
-
-C
-C   Ecriture du fichier histoire au format IOIPSL
-C
-C   Appels succesifs des routines: histwrite
-C
-C   Entree:
-C      time: temps de l'ecriture
-C      vcov: vents v covariants
-C      ucov: vents u covariants
-C      teta: temperature potentielle
-C      phi : geopotentiel instantane
-C      q   : traceurs
-C      masse: masse
-C      ps   :pression au sol
-C      phis : geopotentiel au sol
-C      
-C
-C   L. Fairhead, LMD, 03/99
-C
-C =====================================================================
-C
-C   Declarations
-
-C
-C   Arguments
-C
-
-      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
-      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
-      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
-      REAL phis(ip1jmp1)                  
-      REAL q(ip1jmp1,llm,nqmx)
-      integer time
-
-
-! This routine needs IOIPSL to work
-C   Variables locales
-C
-      integer iq, ii, ll
-      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
-      logical ok_sync
-      integer itau_w
-      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
-
-C
-C  Initialisations
-C
-      ndexu = 0
-      ndexv = 0
-      ndex2d = 0
-      ok_sync =.TRUE.
-      itau_w = itau_dyn + time
-!  Passage aux composantes naturelles du vent
-      call covnat(llm, ucov, vcov, unat, vnat)
-C
-C  Appels a histwrite pour l'ecriture des variables a sauvegarder
-C
-C  Vents U
-C
-      call histwrite(histuid, 'u', itau_w, unat)
-C
-C  Vents V
-C
-      call histwrite(histvid, 'v', itau_w, vnat)
-
-C
-C  Temperature potentielle
-C
-      call histwrite(histid, 'teta', itau_w, teta)
-C
-C  Geopotentiel
-C
-      call histwrite(histid, 'phi', itau_w, phi)
-C
-C  Traceurs
-C
-!        DO iq=1,nqmx
-!          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), 
-!     .                   iip1*jjp1*llm, ndexu)
-!        enddo
-!C
-C  Masse
-C
-      call histwrite(histid,'masse',itau_w, masse)
-C
-C  Pression au sol
-C
-      call histwrite(histid, 'ps', itau_w, ps)
-C
-C  Geopotentiel au sol
-C
-!      call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
-C
-C  Fin
-C
-      if (ok_sync) then
-        call histsync(histid)
-        call histsync(histvid)
-        call histsync(histuid)
-      endif
-      return
-      end
+module writehist_m
+
+  implicit none
+
+contains
+
+  subroutine writehist(vcov, ucov, teta, pk, phi, q, masse, ps, itau_w)
+
+    ! From writehist.F, revision 1403, 2010-07-01 09:02:53
+    ! Écriture du fichier histoire au format IOIPSL
+    ! L. Fairhead, LMD, 03/99
+
+    USE comconst, ONLY: cpp
+    use covnat_m, only: covnat
+    use dimensions, only: llm
+    use histsync_m, only: histsync
+    use histwrite_m, only: histwrite
+    use iniadvtrac_m, only: ttext
+    use inithist_m, only: histid, histvid, histuid
+    use nr_util, only: assert
+    use paramet_m, only: ip1jm, ip1jmp1
+
+    ! Vent covariant :
+    REAL, intent(in):: vcov(:, :, :) ! (iim + 1, jjm, llm)
+    REAL, intent(in):: ucov(:, :, :) ! (iim + 1, jjm + 1, llm)
+
+    REAL, intent(in):: teta(:, :, :) ! (iim + 1, jjm + 1, llm)
+    ! temperature potentielle
+
+    real, intent(in):: pk(:, :, :) ! (iim + 1, jjm + 1, llm)
+    real, intent(in):: phi(:, :, :) ! (iim + 1, jjm + 1, llm) ! geopotential
+    REAL, intent(in):: q(:, :, :, :) ! (iim + 1, jjm + 1, llm, nqmx) traceurs
+    real, intent(in):: masse(:, :, :) ! (iim + 1, jjm + 1, llm)
+    REAL, intent(in):: ps(:, :) ! (iim + 1, jjm + 1) pression au sol
+    integer, intent(in):: itau_w ! temps de l'ecriture
+
+    ! Local:
+    integer iq
+    REAL vnat(ip1jm, llm), unat(ip1jmp1, llm)
+
+    !---------------------------------------------------------------------
+
+    call assert([size(vcov, 1), size(ucov, 1), size(teta, 1), size(phi, 1), &
+         size(pk, 1), size(ps, 1), size(masse, 1)] == size(q, 1), &
+         "writehist iim")
+    call assert([size(vcov, 2) + 1, size(ucov, 2), size(teta, 2), &
+         size(phi, 2), size(pk, 2), size(ps, 2), size(masse, 2)] &
+         == size(q, 2), "writehist jjm")
+    call assert([size(vcov, 3), size(ucov, 3), size(teta, 3), size(phi, 3), &
+         size(pk, 3), size(masse, 3), size(q, 3)] == llm, "writehist llm")
+
+    call covnat(llm, ucov, vcov, unat, vnat)
+
+    call histwrite(histuid, 'u', itau_w, unat)
+    call histwrite(histvid, 'v', itau_w, vnat)
+    call histwrite(histid, 'theta', itau_w, teta)
+    call histwrite(histid, 'temp', itau_w, teta * pk / cpp)
+    call histwrite(histid, 'phi', itau_w, phi)
+
+    DO iq = 1, size(q, 4)
+       call histwrite(histid, ttext(iq), itau_w, q(:, :, :, iq))
+    enddo
+
+    call histwrite(histid, 'masse', itau_w, masse)
+    call histwrite(histid, 'ps', itau_w, ps)
+
+    call histsync(histid)
+    call histsync(histvid)
+    call histsync(histuid)
+
+  end subroutine writehist
+
+end module writehist_m