source: LMDZ.3.3/trunk/libf/dyn3d/wrgrads.F @ 3246

Last change on this file since 3246 was 2, checked in by lmdz, 25 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 3.5 KB
Line 
1      subroutine wrgrads(if,nl,field,name,titlevar)
2      implicit none
3
4c   Declarations
5c    if indice du fichier
6c    nl nombre de couches
7c    field   champ
8c    name    petit nom
9c    titlevar   Titre
10
11#include "gradsdef.h"
12
13c   arguments
14      integer if,nl
15      real field(imx*jmx*lmx)
16      character*10 name,file
17      character*10 titlevar
18
19c   local
20
21      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
22
23      logical writectl
24
25
26      writectl=.false.
27
28c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
29      iii=iid(if)
30      iji=jid(if)
31      iif=ifd(if)
32      ijf=jfd(if)
33      im=iif-iii+1
34      jm=ijf-iji+1
35      lm=lmd(if)
36
37c      print*,'im,jm,lm,name,firsttime(if)'
38c      print*,im,jm,lm,name,firsttime(if)
39
40      if(firsttime(if)) then
41         if(name.eq.var(1,if)) then
42            firsttime(if)=.false.
43            ivar(if)=1
44         print*,'fin de l initialiation de l ecriture du fichier'
45         print*,file
46           print*,'fichier no: ',if
47           print*,'unit ',unit(if)
48           print*,'nvar  ',nvar(if)
49           print*,'vars ',(var(iv,if),iv=1,nvar(if))
50         else
51            ivar(if)=ivar(if)+1
52            nvar(if)=ivar(if)
53            var(ivar(if),if)=name
54            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
55            nld(ivar(if),if)=nl
56            print*,'initialisation ecriture de ',var(ivar(if),if)
57            print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
58         endif
59         writectl=.true.
60         itime(if)=1
61      else
62         ivar(if)=mod(ivar(if),nvar(if))+1
63         if (ivar(if).eq.nvar(if)) then
64            writectl=.true.
65            itime(if)=itime(if)+1
66         endif
67
68         if(var(ivar(if),if).ne.name) then
69           print*,'Il faut stoker la meme succession de champs a chaque'
70           print*,'pas de temps'
71           print*,'fichier no: ',if
72           print*,'unit ',unit(if)
73           print*,'nvar  ',nvar(if)
74           print*,'vars ',(var(iv,if),iv=1,nvar(if))
75
76           stop
77         endif
78      endif
79
80c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
81c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
82      do l=1,nl
83         irec(if)=irec(if)+1
84c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
85c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
86c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
87         write(unit(if)+1,rec=irec(if))
88     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
89     s   ,i=iii,iif),j=iji,ijf)
90      enddo
91      if (writectl) then
92
93      file=fichier(if)
94c   WARNING! on reecrase le fichier .ctl a chaque ecriture
95      open(unit(if),file=file(1:lnblnk(file))//'.ctl',
96     &         form='formatted',status='unknown')
97      write(unit(if),'(a5,1x,a40)')
98     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
99
100      write(unit(if),'(a12)') 'UNDEF 1.0E30'
101      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
102      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
103      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
104      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
105      write(unit(if),'(a4,i10,a30)')
106     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
107      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
108      do iv=1,nvar(if)
109c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
110c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
111         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
112     &     ,99,tvar(iv,if)
113      enddo
114      write(unit(if),'(a7)') 'ENDVARS'
115c
1161000  format(a5,3x,i4,i3,1x,a39)
117
118      close(unit(if))
119
120      endif ! writectl
121
122      return
123
124      END
125
Note: See TracBrowser for help on using the repository browser.