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