/[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 102 by guez, Tue Jul 15 13:43:24 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 nl
20      REAL, INTENT(IN):: field(imx*jmx*lmx)
21    CHARACTER *10 name, file    CHARACTER *10 name, file
22    CHARACTER *10 titlevar    CHARACTER *10 titlevar
23    
# Line 29  SUBROUTINE wrgrads(if, nl, field, name, Line 30  SUBROUTINE wrgrads(if, nl, field, name,
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) = titlevar(1:lnblnk(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=file(1:lnblnk(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 ', '^' // file(1:lnblnk(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.102
  ViewVC Help
Powered by ViewVC 1.1.21