/[lmdze]/trunk/dyn3d/wrgrads.f
ViewVC logotype

Diff of /trunk/dyn3d/wrgrads.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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