source: LMDZ6/trunk/libf/dyn3d/wrgrads.f90

!
! $Header$
!
subroutine wrgrads(if,nl,field,name,titlevar)
  USE gradsdef_mod_h
  implicit none

  !   Declarations
  !    if indice du fichier
  !    nl nombre de couches
  !    field   champ
  !    name    petit nom
  !    titlevar   Titre

  !   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(len=10) :: name,file
  character(len=10) :: titlevar

  !   local

  integer :: im,jm,lm,i,j,l,iv,iii,iji,iif,ijf

  logical :: writectl


  writectl=.false.

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

  ! print*,'im,jm,lm,name,firsttime(if)'
  ! 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
        ! 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))
       CALL abort_gcm("wrgrads","problem",1)
     endif
  endif

  ! print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
  ! 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
     ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
  !    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
  !    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)
  !   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)
     ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
     ! 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'
  !
1000   format(a5,3x,i4,i3,1x,a39)

  close(unit(if))

  endif ! writectl

  return

END SUBROUTINE wrgrads