/[lmdze]/trunk/dyn3d/wrgrads.f
ViewVC logotype

Diff of /trunk/dyn3d/wrgrads.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/wrgrads.f revision 29 by guez, Tue Mar 30 10:44:42 2010 UTC trunk/dyn3d/wrgrads.f revision 102 by guez, Tue Jul 15 13:43:24 2014 UTC
# Line 1  Line 1 
 !  
 ! $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, intent(in):: 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)  
1    
2        close(unit(if))  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/wrgrads.F,v 1.2 2004/06/22 11:45:30
3    ! lmdzadmin Exp $
4    
5        endif ! writectl  SUBROUTINE wrgrads(i_f, nl, field, name, titlevar)
6      USE gradsdef
7      IMPLICIT NONE
8    
9      ! Declarations
10      ! i_f indice du fichier
11      ! nl nombre de couches
12      ! field   champ
13      ! name    petit nom
14      ! titlevar   Titre
15    
16    
17      ! arguments
18      INTEGER, INTENT(IN):: i_f
19      integer nl
20      REAL, INTENT(IN):: field(imx*jmx*lmx)
21      CHARACTER *10 name, file
22      CHARACTER *10 titlevar
23    
24      ! local
25    
26      INTEGER im, jm, lm, i, j, l, lnblnk, iv, iii, iji, iif, ijf
27    
28      LOGICAL writectl
29    
30    
31      writectl = .FALSE.
32    
33      PRINT *, i_f, iid(i_f), jid(i_f), ifd(i_f), jfd(i_f)
34      iii = iid(i_f)
35      iji = jid(i_f)
36      iif = ifd(i_f)
37      ijf = jfd(i_f)
38      im = iif - iii + 1
39      jm = ijf - iji + 1
40      lm = lmd(i_f)
41    
42      PRINT *, 'im,jm,lm,name,firsttime(i_f)'
43      PRINT *, im, jm, lm, name, firsttime(i_f)
44    
45      IF (firsttime(i_f)) THEN
46        IF (name==var(1,i_f)) THEN
47          firsttime(i_f) = .FALSE.
48          ivar(i_f) = 1
49          PRINT *, 'fin de l initialiation de l ecriture du fichier'
50          PRINT *, file
51          PRINT *, 'fichier no: ', i_f
52          PRINT *, 'unit ', unit(i_f)
53          PRINT *, 'nvar  ', nvar(i_f)
54          PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))
55        ELSE
56          ivar(i_f) = ivar(i_f) + 1
57          nvar(i_f) = ivar(i_f)
58          var(ivar(i_f), i_f) = name
59          tvar(ivar(i_f), i_f) = titlevar(1:lnblnk(titlevar))
60          nld(ivar(i_f), i_f) = nl
61          PRINT *, 'initialisation ecriture de ', var(ivar(i_f), i_f)
62          PRINT *, 'i_f ivar(i_f) nld ', i_f, ivar(i_f), nld(ivar(i_f), i_f)
63        END IF
64        writectl = .TRUE.
65        itime(i_f) = 1
66      ELSE
67        ivar(i_f) = mod(ivar(i_f), nvar(i_f)) + 1
68        IF (ivar(i_f)==nvar(i_f)) THEN
69          writectl = .TRUE.
70          itime(i_f) = itime(i_f) + 1
71        END IF
72    
73        IF (var(ivar(i_f),i_f)/=name) THEN
74          PRINT *, 'Il faut stoker la meme succession de champs a chaque'
75          PRINT *, 'pas de temps'
76          PRINT *, 'fichier no: ', i_f
77          PRINT *, 'unit ', unit(i_f)
78          PRINT *, 'nvar  ', nvar(i_f)
79          PRINT *, 'vars ', (var(iv,i_f), iv=1, nvar(i_f))
80    
81          STOP
82        END IF
83      END IF
84    
85      PRINT *, 'ivar(i_f),nvar(i_f),var(ivar(i_f),i_f),writectl'
86      PRINT *, ivar(i_f), nvar(i_f), var(ivar(i_f), i_f), writectl
87      DO l = 1, nl
88        irec(i_f) = irec(i_f) + 1
89        ! print*,'Ecrit rec=',irec(i_f),iii,iif,iji,ijf,
90        ! s (l-1)*imd(i_f)*jmd(i_f)+(iji-1)*imd(i_f)+iii
91        ! s ,(l-1)*imd(i_f)*jmd(i_f)+(ijf-1)*imd(i_f)+iif
92        WRITE (unit(i_f)+1, REC=irec(i_f))((field((l-1)*imd(i_f)*jmd(i_f)+ &
93          (j-1)*imd(i_f)+i),i=iii,iif), j=iji, ijf)
94      END DO
95      IF (writectl) THEN
96    
97        file = fichier(i_f)
98        ! WARNING! on reecrase le fichier .ctl a chaque ecriture
99        OPEN (unit(i_f), FILE=file(1:lnblnk(file))//'.ctl', FORM='formatted', &
100          STATUS='unknown')
101        WRITE (unit(i_f), '(a5,1x,a40)') 'DSET ', '^' // file(1:lnblnk(file)) // &
102          '.dat'
103    
104        WRITE (unit(i_f), '(a12)') 'UNDEF 1.0E30'
105        WRITE (unit(i_f), '(a5,1x,a40)') 'TITLE ', title(i_f)
106        CALL formcoord(unit(i_f), im, xd(iii,i_f), 1., .FALSE., 'XDEF')
107        CALL formcoord(unit(i_f), jm, yd(iji,i_f), 1., .TRUE., 'YDEF')
108        CALL formcoord(unit(i_f), lm, zd(1,i_f), 1., .FALSE., 'ZDEF')
109        WRITE (unit(i_f), '(a4,i10,a30)') 'TDEF ', itime(i_f), &
110          ' LINEAR 02JAN1987 1MO '
111        WRITE (unit(i_f), '(a4,2x,i5)') 'VARS', nvar(i_f)
112        DO iv = 1, nvar(i_f)
113          ! print*,'i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)'
114          ! print*,i_f,var(iv,i_f),nld(iv,i_f),nld(iv,i_f)-1/nld(iv,i_f)
115          WRITE (unit(i_f), 1000) var(iv, i_f), nld(iv, i_f) - 1/nld(iv, i_f), 99, &
116            tvar(iv, i_f)
117        END DO
118        WRITE (unit(i_f), '(a7)') 'ENDVARS'
119    
120    1000 FORMAT (A5, 3X, I4, I3, 1X, A39)
121    
122        return      CLOSE (unit(i_f))
123    
124        END    END IF ! writectl
125    
126      RETURN
127    
128    END SUBROUTINE wrgrads
129    
Legend:
Removed from v.29  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.21