source: LMDZ4/branches/LMDZ4V5.0-LF/libf/dyn3d/wrgrads.F @ 5017

Last change on this file since 5017 was 1025, checked in by lmdzadmin, 16 years ago

Modif pour que ca tourne avec des sorties R4 à partir d'une compilation R8.
FH/IM

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.7 KB
Line 
1!
2! $Header$
3!
4      subroutine wrgrads(if,nl,field,name,titlevar)
5      implicit none
6
7c   Declarations
8c    if indice du fichier
9c    nl nombre de couches
10c    field   champ
11c    name    petit nom
12c    titlevar   Titre
13
14#include "gradsdef.h"
15
16c   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
26c   local
27
28      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
29
30      logical writectl
31
32
33      writectl=.false.
34
35c     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
44c     print*,'im,jm,lm,name,firsttime(if)'
45c     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)=titlevar(1:lnblnk(titlevar))
62            nld(ivar(if),if)=nl
63c           print*,'initialisation ecriture de ',var(ivar(if),if)
64c           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
87c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
88c     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
92c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
93c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
94c    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)
102c   WARNING! on reecrase le fichier .ctl a chaque ecriture
103      open(unit(if),file=file(1:lnblnk(file))//'.ctl'
104     &         ,form='formatted',status='unknown')
105      write(unit(if),'(a5,1x,a40)')
106     &       'DSET ','^'//file(1:lnblnk(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)
117c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
118c        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'
123c
1241000  format(a5,3x,i4,i3,1x,a39)
125
126      close(unit(if))
127
128      endif ! writectl
129
130      return
131
132      END
133
Note: See TracBrowser for help on using the repository browser.