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