| 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,lnblnk,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)=titlevar(1:lnblnk(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=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) |
|---|
| 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 | |
|---|
