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