! $Header$

SUBROUTINE wrgrads(if, nl, field, name, titlevar)
  IMPLICIT NONE

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

  INCLUDE "gradsdef.h"

  !   arguments
  integer :: if, nl
  real :: field(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==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)==nvar(if)) then
      writectl = .TRUE.
      itime(if) = itime(if) + 1
    endif

    if(var(ivar(if), if)/=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
  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)) &
            ((field((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



END SUBROUTINE wrgrads