source: lmdz_wrf/WRFV3/lmdz/wrgrads.F90 @ 1

!
! $Header$
!
      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)

      integer, parameter:: wp = selected_real_kind(p=6, r=36)
      real(wp) field4(imx*jmx*lmx)

      character*10 name,file
      character*10 titlevar

!c   local

      integer im,jm,lm,i,j,l,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)=trim(titlevar)
            nld(ivar(if),if)=nl
!c           print*,'initialisation ecriture de ',var(ivar(if),if)
!c           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
      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
      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))                                              &
       &   ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)                           &
       &   ,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=trim(file)//'.ctl'                                          &
       &         ,form='formatted',status='unknown')
      write(unit(if),'(a5,1x,a40)')                                                  &
       &       'DSET ','^'//trim(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