source: LMDZ6/trunk/libf/dyn3dmem/wrgrads.f90 @ 5280

Last change on this file since 5280 was 5246, checked in by abarral, 8 weeks ago

Convert fixed-form to free-form sources .F -> .{f,F}90
(WIP: some .F remain, will be handled in subsequent commits)

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 3.3 KB
Line 
1!
2! $Header$
3!
4subroutine 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  !
1181000   format(a5,3x,i4,i3,1x,a39)
119
120  close(unit(if))
121
122  endif ! writectl
123
124  return
125
126END SUBROUTINE wrgrads
127
Note: See TracBrowser for help on using the repository browser.