--- trunk/libf/dyn3d/wrgrads.f 2008/02/27 13:16:39 3 +++ trunk/dyn3d/wrgrads.f 2014/07/15 13:43:24 102 @@ -1,128 +1,129 @@ -! -! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/wrgrads.F,v 1.2 2004/06/22 11:45:30 lmdzadmin Exp $ -! - subroutine wrgrads(if,nl,field,name,titlevar) - use gradsdef - implicit none - -c Declarations -c if indice du fichier -c nl nombre de couches -c field champ -c name petit nom -c titlevar Titre - - -c arguments - integer if,nl - real field(imx*jmx*lmx) - character*10 name,file - character*10 titlevar - -c local - - integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf - - logical writectl - - - writectl=.false. - - print*,if,iid(if),jid(if),ifd(if),jfd(if) - iii=iid(if) - iji=jid(if) - iif=ifd(if) - ijf=jfd(if) - im=iif-iii+1 - jm=ijf-iji+1 - lm=lmd(if) - - print*,'im,jm,lm,name,firsttime(if)' - print*,im,jm,lm,name,firsttime(if) - - if(firsttime(if)) then - if(name.eq.var(1,if)) then - firsttime(if)=.false. - ivar(if)=1 - print*,'fin de l initialiation de l ecriture du fichier' - print*,file - print*,'fichier no: ',if - print*,'unit ',unit(if) - print*,'nvar ',nvar(if) - print*,'vars ',(var(iv,if),iv=1,nvar(if)) - else - ivar(if)=ivar(if)+1 - nvar(if)=ivar(if) - var(ivar(if),if)=name - tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) - nld(ivar(if),if)=nl - print*,'initialisation ecriture de ',var(ivar(if),if) - print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) - endif - writectl=.true. - itime(if)=1 - else - ivar(if)=mod(ivar(if),nvar(if))+1 - if (ivar(if).eq.nvar(if)) then - writectl=.true. - itime(if)=itime(if)+1 - endif - - if(var(ivar(if),if).ne.name) then - print*,'Il faut stoker la meme succession de champs a chaque' - print*,'pas de temps' - print*,'fichier no: ',if - print*,'unit ',unit(if) - print*,'nvar ',nvar(if) - print*,'vars ',(var(iv,if),iv=1,nvar(if)) - - stop - endif - endif - - print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' - print*,ivar(if),nvar(if),var(ivar(if),if),writectl - do l=1,nl - irec(if)=irec(if)+1 -c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, -c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii -c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif - write(unit(if)+1,rec=irec(if)) - s ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) - s ,i=iii,iif),j=iji,ijf) - enddo - if (writectl) then - - file=fichier(if) -c WARNING! on reecrase le fichier .ctl a chaque ecriture - open(unit(if),file=file(1:lnblnk(file))//'.ctl' - & ,form='formatted',status='unknown') - write(unit(if),'(a5,1x,a40)') - & 'DSET ','^'//file(1:lnblnk(file))//'.dat' - - write(unit(if),'(a12)') 'UNDEF 1.0E30' - write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) - call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') - call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') - call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') - write(unit(if),'(a4,i10,a30)') - & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' - write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) - do iv=1,nvar(if) -c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' -c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) - write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) - & ,99,tvar(iv,if) - enddo - write(unit(if),'(a7)') 'ENDVARS' -c -1000 format(a5,3x,i4,i3,1x,a39) - close(unit(if)) +! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/wrgrads.F,v 1.2 2004/06/22 11:45:30 +! lmdzadmin Exp $ - endif ! writectl +SUBROUTINE wrgrads(i_f, nl, field, name, titlevar) + USE gradsdef + IMPLICIT NONE + + ! Declarations + ! i_f indice du fichier + ! nl nombre de couches + ! field champ + ! name petit nom + ! titlevar Titre + + + ! arguments + INTEGER, INTENT(IN):: i_f + integer nl + REAL, INTENT(IN):: field(imx*jmx*lmx) + CHARACTER *10 name, file + CHARACTER *10 titlevar + + ! local + + INTEGER im, jm, lm, i, j, l, lnblnk, iv, iii, iji, iif, ijf + + LOGICAL writectl + + + writectl = .FALSE. + + PRINT *, i_f, iid(i_f), jid(i_f), ifd(i_f), jfd(i_f) + iii = iid(i_f) + iji = jid(i_f) + iif = ifd(i_f) + ijf = jfd(i_f) + im = iif - iii + 1 + jm = ijf - iji + 1 + lm = lmd(i_f) + + PRINT *, 'im,jm,lm,name,firsttime(i_f)' + PRINT *, im, jm, lm, name, firsttime(i_f) + + IF (firsttime(i_f)) THEN + IF (name==var(1,i_f)) THEN + firsttime(i_f) = .FALSE. + ivar(i_f) = 1 + PRINT *, 'fin de l initialiation de l ecriture du fichier' + PRINT *, file + PRINT *, 'fichier no: ', i_f + PRINT *, 'unit ', unit(i_f) + PRINT *, 'nvar ', nvar(i_f) + PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f)) + ELSE + ivar(i_f) = ivar(i_f) + 1 + nvar(i_f) = ivar(i_f) + var(ivar(i_f), i_f) = name + tvar(ivar(i_f), i_f) = titlevar(1:lnblnk(titlevar)) + nld(ivar(i_f), i_f) = nl + PRINT *, 'initialisation ecriture de ', var(ivar(i_f), i_f) + PRINT *, 'i_f ivar(i_f) nld ', i_f, ivar(i_f), nld(ivar(i_f), i_f) + END IF + writectl = .TRUE. + itime(i_f) = 1 + ELSE + ivar(i_f) = mod(ivar(i_f), nvar(i_f)) + 1 + IF (ivar(i_f)==nvar(i_f)) THEN + writectl = .TRUE. + itime(i_f) = itime(i_f) + 1 + END IF + + IF (var(ivar(i_f),i_f)/=name) THEN + PRINT *, 'Il faut stoker la meme succession de champs a chaque' + PRINT *, 'pas de temps' + PRINT *, 'fichier no: ', i_f + PRINT *, 'unit ', unit(i_f) + PRINT *, 'nvar ', nvar(i_f) + PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f)) + + STOP + END IF + END IF + + PRINT *, 'ivar(i_f),nvar(i_f),var(ivar(i_f),i_f),writectl' + PRINT *, ivar(i_f), nvar(i_f), var(ivar(i_f), i_f), writectl + DO l = 1, nl + irec(i_f) = irec(i_f) + 1 + ! print*,'Ecrit rec=',irec(i_f),iii,iif,iji,ijf, + ! s (l-1)*imd(i_f)*jmd(i_f)+(iji-1)*imd(i_f)+iii + ! s ,(l-1)*imd(i_f)*jmd(i_f)+(ijf-1)*imd(i_f)+iif + WRITE (unit(i_f)+1, REC=irec(i_f))((field((l-1)*imd(i_f)*jmd(i_f)+ & + (j-1)*imd(i_f)+i),i=iii,iif), j=iji, ijf) + END DO + IF (writectl) THEN + + file = fichier(i_f) + ! WARNING! on reecrase le fichier .ctl a chaque ecriture + OPEN (unit(i_f), FILE=file(1:lnblnk(file))//'.ctl', FORM='formatted', & + STATUS='unknown') + WRITE (unit(i_f), '(a5,1x,a40)') 'DSET ', '^' // file(1:lnblnk(file)) // & + '.dat' + + WRITE (unit(i_f), '(a12)') 'UNDEF 1.0E30' + WRITE (unit(i_f), '(a5,1x,a40)') 'TITLE ', title(i_f) + CALL formcoord(unit(i_f), im, xd(iii,i_f), 1., .FALSE., 'XDEF') + CALL formcoord(unit(i_f), jm, yd(iji,i_f), 1., .TRUE., 'YDEF') + CALL formcoord(unit(i_f), lm, zd(1,i_f), 1., .FALSE., 'ZDEF') + WRITE (unit(i_f), '(a4,i10,a30)') 'TDEF ', itime(i_f), & + ' LINEAR 02JAN1987 1MO ' + WRITE (unit(i_f), '(a4,2x,i5)') 'VARS', nvar(i_f) + DO iv = 1, nvar(i_f) + ! print*,'i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)' + ! print*,i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f) + WRITE (unit(i_f), 1000) var(iv, i_f), nld(iv, i_f) - 1/nld(iv, i_f), 99, & + tvar(iv, i_f) + END DO + WRITE (unit(i_f), '(a7)') 'ENDVARS' + +1000 FORMAT (A5, 3X, I4, I3, 1X, A39) - return + CLOSE (unit(i_f)) - END + END IF ! writectl + + RETURN + +END SUBROUTINE wrgrads