trunk/dyn3d/wrgrads.f


! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/wrgrads.F,v 1.2 2004/06/22 11:45:30
! lmdzadmin Exp $

SUBROUTINE wrgrads(i_f, nl, field, name, titlevar)
  USE gradsdef
  IMPLICIT NONE

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


  ! arguments
  INTEGER, INTENT(IN):: i_f
  integer nl
  REAL, INTENT(IN):: field(imx*jmx*lmx)
  CHARACTER(len=10) name, file
  CHARACTER(len=10) titlevar

  ! local

  INTEGER im, jm, lm, i, j, l, lnblnk, iv, iii, iji, iif, ijf

  LOGICAL writectl


  writectl = .FALSE.

  PRINT *, i_f, iid(i_f), jid(i_f), ifd(i_f), jfd(i_f)
  iii = iid(i_f)
  iji = jid(i_f)
  iif = ifd(i_f)
  ijf = jfd(i_f)
  im = iif - iii + 1
  jm = ijf - iji + 1
  lm = lmd(i_f)

  PRINT *, 'im,jm,lm,name,firsttime(i_f)'
  PRINT *, im, jm, lm, name, firsttime(i_f)

  IF (firsttime(i_f)) THEN
    IF (name==var(1,i_f)) THEN
      firsttime(i_f) = .FALSE.
      ivar(i_f) = 1
      PRINT *, 'fin de l initialiation de l ecriture du fichier'
      PRINT *, file
      PRINT *, 'fichier no: ', i_f
      PRINT *, 'unit ', unit(i_f)
      PRINT *, 'nvar  ', nvar(i_f)
      PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))
    ELSE
      ivar(i_f) = ivar(i_f) + 1
      nvar(i_f) = ivar(i_f)
      var(ivar(i_f), i_f) = name
      tvar(ivar(i_f), i_f) = titlevar(1:lnblnk(titlevar))
      nld(ivar(i_f), i_f) = nl
      PRINT *, 'initialisation ecriture de ', var(ivar(i_f), i_f)
      PRINT *, 'i_f ivar(i_f) nld ', i_f, ivar(i_f), nld(ivar(i_f), i_f)
    END IF
    writectl = .TRUE.
    itime(i_f) = 1
  ELSE
    ivar(i_f) = mod(ivar(i_f), nvar(i_f)) + 1
    IF (ivar(i_f)==nvar(i_f)) THEN
      writectl = .TRUE.
      itime(i_f) = itime(i_f) + 1
    END IF

    IF (var(ivar(i_f),i_f)/=name) THEN
      PRINT *, 'Il faut stoker la meme succession de champs a chaque'
      PRINT *, 'pas de temps'
      PRINT *, 'fichier no: ', i_f
      PRINT *, 'unit ', unit(i_f)
      PRINT *, 'nvar  ', nvar(i_f)
      PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))

      STOP
    END IF
  END IF

  PRINT *, 'ivar(i_f),nvar(i_f),var(ivar(i_f),i_f),writectl'
  PRINT *, ivar(i_f), nvar(i_f), var(ivar(i_f), i_f), writectl
  DO l = 1, nl
    irec(i_f) = irec(i_f) + 1
    ! print*,'Ecrit rec=',irec(i_f),iii,iif,iji,ijf,
    ! s (l-1)*imd(i_f)*jmd(i_f)+(iji-1)*imd(i_f)+iii
    ! s ,(l-1)*imd(i_f)*jmd(i_f)+(ijf-1)*imd(i_f)+iif
    WRITE (unit(i_f)+1, REC=irec(i_f))((field((l-1)*imd(i_f)*jmd(i_f)+ &
      (j-1)*imd(i_f)+i),i=iii,iif), j=iji, ijf)
  END DO
  IF (writectl) THEN

    file = fichier(i_f)
    ! WARNING! on reecrase le fichier .ctl a chaque ecriture
    OPEN (unit(i_f), FILE=file(1:lnblnk(file))//'.ctl', FORM='formatted', &
      STATUS='unknown')
    WRITE (unit(i_f), '(a5,1x,a40)') 'DSET ', '^' // file(1:lnblnk(file)) // &
      '.dat'

    WRITE (unit(i_f), '(a12)') 'UNDEF 1.0E30'
    WRITE (unit(i_f), '(a5,1x,a40)') 'TITLE ', title(i_f)
    CALL formcoord(unit(i_f), im, xd(iii,i_f), 1., .FALSE., 'XDEF')
    CALL formcoord(unit(i_f), jm, yd(iji,i_f), 1., .TRUE., 'YDEF')
    CALL formcoord(unit(i_f), lm, zd(1,i_f), 1., .FALSE., 'ZDEF')
    WRITE (unit(i_f), '(a4,i10,a30)') 'TDEF ', itime(i_f), &
      ' LINEAR 02JAN1987 1MO '
    WRITE (unit(i_f), '(a4,2x,i5)') 'VARS', nvar(i_f)
    DO iv = 1, nvar(i_f)
      ! print*,'i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)'
      ! print*,i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)
      WRITE (unit(i_f), 1000) var(iv, i_f), nld(iv, i_f) - 1/nld(iv, i_f), 99, &
        tvar(iv, i_f)
    END DO
    WRITE (unit(i_f), '(a7)') 'ENDVARS'

1000 FORMAT (A5, 3X, I4, I3, 1X, A39)

    CLOSE (unit(i_f))

  END IF ! writectl

  RETURN

END SUBROUTINE wrgrads

1	guez	3
2	guez	81	! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/wrgrads.F,v 1.2 2004/06/22 11:45:30
3			! lmdzadmin Exp $
4	guez	3
5	guez	102	SUBROUTINE wrgrads(i_f, nl, field, name, titlevar)
6	guez	81	USE gradsdef
7			IMPLICIT NONE
8	guez	3
9	guez	81	! Declarations
10	guez	102	! i_f indice du fichier
11	guez	81	! nl nombre de couches
12			! field champ
13			! name petit nom
14			! titlevar Titre
15	guez	3
16
17	guez	81	! arguments
18	guez	102	INTEGER, INTENT(IN):: i_f
19			integer nl
20			REAL, INTENT(IN):: field(imxjmxlmx)
21	guez	105	CHARACTER(len=10) name, file
22			CHARACTER(len=10) titlevar
23	guez	3
24	guez	81	! local
25	guez	3
26	guez	81	INTEGER im, jm, lm, i, j, l, lnblnk, iv, iii, iji, iif, ijf
27	guez	3
28	guez	81	LOGICAL writectl
29	guez	3
30
31	guez	81	writectl = .FALSE.
32	guez	3
33	guez	102	PRINT *, i_f, iid(i_f), jid(i_f), ifd(i_f), jfd(i_f)
34			iii = iid(i_f)
35			iji = jid(i_f)
36			iif = ifd(i_f)
37			ijf = jfd(i_f)
38	guez	81	im = iif - iii + 1
39			jm = ijf - iji + 1
40	guez	102	lm = lmd(i_f)
41	guez	3
42	guez	102	PRINT *, 'im,jm,lm,name,firsttime(i_f)'
43			PRINT *, im, jm, lm, name, firsttime(i_f)
44	guez	3
45	guez	102	IF (firsttime(i_f)) THEN
46			IF (name==var(1,i_f)) THEN
47			firsttime(i_f) = .FALSE.
48			ivar(i_f) = 1
49	guez	81	PRINT *, 'fin de l initialiation de l ecriture du fichier'
50			PRINT *, file
51	guez	102	PRINT *, 'fichier no: ', i_f
52			PRINT *, 'unit ', unit(i_f)
53			PRINT *, 'nvar ', nvar(i_f)
54			PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))
55	guez	81	ELSE
56	guez	102	ivar(i_f) = ivar(i_f) + 1
57			nvar(i_f) = ivar(i_f)
58			var(ivar(i_f), i_f) = name
59			tvar(ivar(i_f), i_f) = titlevar(1:lnblnk(titlevar))
60			nld(ivar(i_f), i_f) = nl
61			PRINT *, 'initialisation ecriture de ', var(ivar(i_f), i_f)
62			PRINT *, 'i_f ivar(i_f) nld ', i_f, ivar(i_f), nld(ivar(i_f), i_f)
63	guez	81	END IF
64			writectl = .TRUE.
65	guez	102	itime(i_f) = 1
66	guez	81	ELSE
67	guez	102	ivar(i_f) = mod(ivar(i_f), nvar(i_f)) + 1
68			IF (ivar(i_f)==nvar(i_f)) THEN
69	guez	81	writectl = .TRUE.
70	guez	102	itime(i_f) = itime(i_f) + 1
71	guez	81	END IF
72	guez	3
73	guez	102	IF (var(ivar(i_f),i_f)/=name) THEN
74	guez	81	PRINT *, 'Il faut stoker la meme succession de champs a chaque'
75			PRINT *, 'pas de temps'
76	guez	102	PRINT *, 'fichier no: ', i_f
77			PRINT *, 'unit ', unit(i_f)
78			PRINT *, 'nvar ', nvar(i_f)
79			PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))
80	guez	3
81	guez	81	STOP
82			END IF
83			END IF
84	guez	3
85	guez	102	PRINT *, 'ivar(i_f),nvar(i_f),var(ivar(i_f),i_f),writectl'
86			PRINT *, ivar(i_f), nvar(i_f), var(ivar(i_f), i_f), writectl
87	guez	81	DO l = 1, nl
88	guez	102	irec(i_f) = irec(i_f) + 1
89			! print*,'Ecrit rec=',irec(i_f),iii,iif,iji,ijf,
90			! s (l-1)imd(i_f)jmd(i_f)+(iji-1)*imd(i_f)+iii
91			! s ,(l-1)imd(i_f)jmd(i_f)+(ijf-1)*imd(i_f)+iif
92			WRITE (unit(i_f)+1, REC=irec(i_f))((field((l-1)imd(i_f)jmd(i_f)+ &
93			(j-1)*imd(i_f)+i),i=iii,iif), j=iji, ijf)
94	guez	81	END DO
95			IF (writectl) THEN
96	guez	3
97	guez	102	file = fichier(i_f)
98	guez	81	! WARNING! on reecrase le fichier .ctl a chaque ecriture
99	guez	102	OPEN (unit(i_f), FILE=file(1:lnblnk(file))//'.ctl', FORM='formatted', &
100	guez	81	STATUS='unknown')
101	guez	102	WRITE (unit(i_f), '(a5,1x,a40)') 'DSET ', '^' // file(1:lnblnk(file)) // &
102	guez	81	'.dat'
103	guez	3
104	guez	102	WRITE (unit(i_f), '(a12)') 'UNDEF 1.0E30'
105			WRITE (unit(i_f), '(a5,1x,a40)') 'TITLE ', title(i_f)
106			CALL formcoord(unit(i_f), im, xd(iii,i_f), 1., .FALSE., 'XDEF')
107			CALL formcoord(unit(i_f), jm, yd(iji,i_f), 1., .TRUE., 'YDEF')
108			CALL formcoord(unit(i_f), lm, zd(1,i_f), 1., .FALSE., 'ZDEF')
109			WRITE (unit(i_f), '(a4,i10,a30)') 'TDEF ', itime(i_f), &
110	guez	81	' LINEAR 02JAN1987 1MO '
111	guez	102	WRITE (unit(i_f), '(a4,2x,i5)') 'VARS', nvar(i_f)
112			DO iv = 1, nvar(i_f)
113			! print*,'i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)'
114			! print*,i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)
115			WRITE (unit(i_f), 1000) var(iv, i_f), nld(iv, i_f) - 1/nld(iv, i_f), 99, &
116			tvar(iv, i_f)
117	guez	81	END DO
118	guez	102	WRITE (unit(i_f), '(a7)') 'ENDVARS'
119	guez	3
120	guez	81	1000 FORMAT (A5, 3X, I4, I3, 1X, A39)
121	guez	3
122	guez	102	CLOSE (unit(i_f))
123	guez	3
124	guez	81	END IF ! writectl
125
126			RETURN
127
128			END SUBROUTINE wrgrads
129