/[MITgcm]/MITgcm/pkg/ctrl/ctrl_pack.F
ViewVC logotype

Diff of /MITgcm/pkg/ctrl/ctrl_pack.F

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

revision 1.4 by heimbach, Fri Sep 28 15:15:55 2001 UTC revision 1.5 by heimbach, Sat Jul 13 02:47:32 2002 UTC
# Line 1  Line 1 
 C $Header$  
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
# Line 24  C     !USES: Line 23  C     !USES:
23        implicit none        implicit none
24    
25  c     == global variables ==  c     == global variables ==
26    
27  #include "EEPARAMS.h"  #include "EEPARAMS.h"
28  #include "SIZE.h"  #include "SIZE.h"
29  #include "PARAMS.h"  #include "PARAMS.h"
30  #include "GRID.h"  #include "GRID.h"
31    
32    #include "ecco.h"
33  #include "ctrl.h"  #include "ctrl.h"
34  #include "cost.h"  #include "cost.h"
35    
36    #ifdef ALLOW_ECCO_OPTIMIZATION
37  #include "optim.h"  #include "optim.h"
38    #endif
39    
 C     !INPUT/OUTPUT PARAMETERS:  
40  c     == routine arguments ==  c     == routine arguments ==
41    
42        integer myiter        integer myiter
43        _RL     mytime        _RL     mytime
44        integer mythid        integer mythid
45    
 C     !LOCAL VARIABLES:  
46  c     == local variables ==  c     == local variables ==
47    
48        integer bi,bj  #ifndef ALLOW_ECCO_OPTIMIZATION
49        integer ip,jp        integer optimcycle
50        integer i,j,k  #endif
51    
52          integer i, j, k
53        integer ii        integer ii
54        integer il        integer il
55        integer irec        integer irec
56        integer itlo,ithi        integer ig,jg
57        integer jtlo,jthi        integer ivartype
58        integer jmin,jmax        integer iobcs
       integer imin,imax  
       integer cbuffindex  
       integer cunit  
       integer prec  
59    
60        logical doglobalread        logical doglobalread
61        logical ladinit        logical ladinit
62          integer cbuffindex
63    
64        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )        integer cunit
       _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )  
       _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )  
       _RL     globmsk( snx,nsx,npx,sny,nsy,npy,nr )  
65        _RL     tmpvar        _RL     tmpvar
66    
67        character*(128) cfile        character*(128) cfile
68        character*( 80) fname        character*( 80) weighttype
69    
70          character*( 80) fname_theta
71          character*( 80) fname_salt
72          character*( 80) fname_hflux
73          character*( 80) fname_sflux
74          character*( 80) fname_tauu
75          character*( 80) fname_tauv
76          character*( 80) adfname_theta
77          character*( 80) adfname_salt
78          character*( 80) adfname_hflux
79          character*( 80) adfname_sflux
80          character*( 80) adfname_tauu
81          character*( 80) adfname_tauv
82          character*( 80)   fname_atemp
83          character*( 80) adfname_atemp
84          character*( 80)   fname_aqh
85          character*( 80) adfname_aqh
86          character*( 80)   fname_uwind
87          character*( 80) adfname_uwind
88          character*( 80)   fname_vwind
89          character*( 80) adfname_vwind
90          character*( 80)   fname_obcsn
91          character*( 80) adfname_obcsn
92          character*( 80)   fname_obcss
93          character*( 80) adfname_obcss
94          character*( 80)   fname_obcsw
95          character*( 80) adfname_obcsw
96          character*( 80)   fname_obcse
97          character*( 80) adfname_obcse
98          character*( 80)   fname_diffkr
99          character*( 80) adfname_diffkr
100          character*( 80)   fname_kapgm
101          character*( 80) adfname_kapgm
102          character*( 80)   fname_tr1
103          character*( 80) adfname_tr1
104          character*( 80)   fname_efluxy
105          character*( 80) adfname_efluxy
106          character*( 80)   fname_efluxp
107          character*( 80) adfname_efluxp
108    
109          logical lxxadxx
110    
111  c     == external ==  c     == external ==
112    
113        integer  ilnblnk        integer  ilnblnk
114        external ilnblnk        external ilnblnk
115    
116  c     == end of interface ==  c     == end of interface ==
 CEOP  
117    
118        prec           = precFloat64  #ifndef ALLOW_ECCO_OPTIMIZATION
119        tmpvar         = -9999. _d 0        optimcycle = 0
120    #endif
121    
122        jtlo = 1        tmpvar = -9999. _d 0
       jthi = nsy  
       itlo = 1  
       ithi = nsx  
       jmin = 1  
       jmax = sny  
       imin = 1  
       imax = snx  
123    
124  c--   Tiled files are used.  c--   Tiled files are used.
125        doglobalread = .false.        doglobalread = .false.
# Line 92  c--   Tiled files are used. Line 127  c--   Tiled files are used.
127  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
128        ladinit = .false.        ladinit = .false.
129    
130  c  c--   Assign file names.
 c--   Only the master thread will do I/O.  
       _BEGIN_MASTER( mythid )  
131    
132  c--   read global mask file        call ctrl_set_fname(
133            call MDSREADFIELD_3D_GL( "hFacC",       I     xx_theta_file, fname_theta, adfname_theta, mythid )
134       &                           prec, 'RL', Nr, globmsk,        call ctrl_set_fname(
135       &                           1,  mythid)       I     xx_salt_file, fname_salt, adfname_salt, mythid )
136          call ctrl_set_fname(
137         I     xx_hflux_file, fname_hflux, adfname_hflux, mythid )
138          call ctrl_set_fname(
139         I     xx_sflux_file, fname_sflux, adfname_sflux, mythid )
140          call ctrl_set_fname(
141         I     xx_tauu_file, fname_tauu, adfname_tauu, mythid )
142          call ctrl_set_fname(
143         I     xx_tauv_file, fname_tauv, adfname_tauv, mythid )
144          call ctrl_set_fname(
145         I     xx_atemp_file, fname_atemp, adfname_atemp, mythid )
146          call ctrl_set_fname(
147         I     xx_aqh_file, fname_aqh, adfname_aqh, mythid )
148          call ctrl_set_fname(
149         I     xx_uwind_file, fname_uwind, adfname_uwind, mythid )
150          call ctrl_set_fname(
151         I     xx_vwind_file, fname_vwind, adfname_vwind, mythid )
152          call ctrl_set_fname(
153         I     xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
154          call ctrl_set_fname(
155         I     xx_obcss_file, fname_obcss, adfname_obcss, mythid )
156          call ctrl_set_fname(
157         I     xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
158          call ctrl_set_fname(
159         I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )
160          call ctrl_set_fname(
161         I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
162          call ctrl_set_fname(
163         I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
164          call ctrl_set_fname(
165         I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )
166          call ctrl_set_fname(
167         I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
168          call ctrl_set_fname(
169         I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
170    
171    c
172    c--     Only the master thread will do I/O.
173          _BEGIN_MASTER( mythid )
174    
175  c     >>> Write control vector <<<  c     >>> Write control vector <<<
176    
177            call mdsfindunit( cunit, mythid )  cph   this part was removed since it's not necessary
178            write(cfile(1:128),'(2a,i4.4)')  cph   and causes huge amounts of wall clock time on parallel machines
      &      ctrlname(1:9),'.opt',  
      &      optimcycle  
   
           open( cunit, file   = cfile,  
      &                 status = 'unknown',  
      &                 form   = 'unformatted',  
      &                 access = 'sequential'   )  
   
 c--       Header information.  
             
           write(cunit) nvartype  
           write(cunit) nvarlength  
           write(cunit) expId  
           write(cunit) optimCycle  
           write(cunit) tmpvar  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) (nWetcTile(1,1,k), k=1,nr)  
           write(cunit) (nWetsTile(1,1,k), k=1,nr)  
           write(cunit) (nWetwTile(1,1,k), k=1,nr)  
           write(cunit) (ncvarindex(i), i=1,maxcvars)  
           write(cunit) (ncvarrecs(i),  i=1,maxcvars)  
           write(cunit) (nx,  i=1,maxcvars)  
           write(cunit) (ny,  i=1,maxcvars)  
           write(cunit) (ncvarnrmax(i), i=1,maxcvars)  
           write(cunit) (ncvargrd(i),   i=1,maxcvars)  
           write(cunit)  
   
 #ifdef ALLOW_THETA0_CONTROL  
   
           il=ilnblnk( xx_theta_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_theta_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(1)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wtheta(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
 #endif  
   
 #ifdef ALLOW_SALT0_CONTROL  
   
           il=ilnblnk( xx_salt_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_salt_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(2)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wsalt(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
               
 #endif  
   
 #ifdef ALLOW_TR10_CONTROL  
179    
           il=ilnblnk( xx_tr1_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tr1_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
180    
           write(cunit) ncvarindex(9)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 cph     &                      * sqrt(wtr1(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
               
 #endif  
   
 #ifdef ALLOW_HFLUX0_CONTROL  
   
           il=ilnblnk( xx_hflux_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_hflux_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "whflux",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(3)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SFLUX0_CONTROL  
   
           il=ilnblnk( xx_sflux_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sflux_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsflux",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(4)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUU0_CONTROL  
   
           il=ilnblnk( xx_tauu_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tauu_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauu",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(5)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUV0_CONTROL  
   
           il=ilnblnk( xx_tauv_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tauv_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauv",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(6)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SST0_CONTROL  
   
           il=ilnblnk( xx_sst_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sst_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsst",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(7)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SSS0_CONTROL  
   
           il=ilnblnk( xx_sss_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sss_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsss",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(8)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_DIFFKR_CONTROL  
   
           il=ilnblnk( xx_diffkr_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_diffkr_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(15)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 cph     &                      * sqrt(wdiffkr(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
               
 #endif  
   
 #ifdef ALLOW_KAPGM_CONTROL  
   
           il=ilnblnk( xx_kapgm_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_kapgm_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(16)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 cph     &                      * sqrt(wkapgm(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
               
 #endif  
   
           close ( cunit )  
   
         _END_MASTER( mythid )  
   
 c======================================================================  
   
 c--   read global mask file  
           call MDSREADFIELD_3D_GL( "hFacC",  
      &                           prec, 'RL', Nr, globmsk,  
      &                           1,  mythid)  
181    
182  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
183          lxxadxx = .FALSE.
184    
185            call mdsfindunit( cunit, mythid )            call mdsfindunit( cunit, mythid )
186            write(cfile(1:128),'(2a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
187       &    costname(1:9),'.opt',       &    costname(1:9),'_',yctrlid(1:10),'.opt',
188       &    optimcycle       &    optimcycle
189    
190            open( cunit, file   = cfile,            open( cunit, file   = cfile,
# Line 704  c     >>> Write gradient vector <<< Line 195  c     >>> Write gradient vector <<<
195  c--       Header information.  c--       Header information.
196            write(cunit) nvartype            write(cunit) nvartype
197            write(cunit) nvarlength            write(cunit) nvarlength
198            write(cunit) expId            write(cunit) yctrlid
199            write(cunit) optimCycle            write(cunit) optimCycle
200            write(cunit) fc            write(cunit) fc
201            write(cunit) 1            write(cunit) 1
202            write(cunit) 1            write(cunit) 1
203            write(cunit) 1            write(cunit) 1
204            write(cunit) 1            write(cunit) 1
205            write(cunit) (nWetcTile(1,1,k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
206            write(cunit) (nWetsTile(1,1,k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
207            write(cunit) (nWetwTile(1,1,k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
208              write(cunit) (nWetvGlobal(k), k=1,nr)
209    #ifdef ALLOW_OBCSN_CONTROL
210              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
211    #endif
212    #ifdef ALLOW_OBCSS_CONTROL
213              write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
214    #endif
215    #ifdef ALLOW_OBCSW_CONTROL
216              write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
217    #endif
218    #ifdef ALLOW_OBCSE_CONTROL
219              write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
220    #endif
221            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
222            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
223            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (nx,  i=1,maxcvars)
# Line 723  c--       Header information. Line 227  c--       Header information.
227            write(cunit)            write(cunit)
228    
229  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
230              ivartype = 1
231            il=ilnblnk( xx_theta_file)            call ctrl_set_pack_xyz(
232            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_theta, "hFacC",
233            write(fname(1:80),'(3a,i10.10)')       &         wtheta, lxxadxx, mythid)
      &         yadmark,xx_theta_file(1:il),'.',optimcycle  
   
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(1)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wtheta(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
234  #endif  #endif
235    
236  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
237              ivartype = 2
238            il=ilnblnk( xx_salt_file)            call ctrl_set_pack_xyz(
239            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_salt, "hFacC",
240            write(fname(1:80),'(3a,i10.10)')       &         wsalt, lxxadxx, mythid)
241       &         yadmark,xx_salt_file(1:il),'.',optimcycle  #endif
242    
243            call MDSREADFIELD_3D_GL( fname,  #if (defined (ALLOW_HFLUX_CONTROL) || \
244       &                          prec, 'RL', Nr,       defined (ALLOW_HFLUX0_CONTROL))
245       &                          globfld3d,            ivartype = 3
246       &                          1,  mythid)            write(weighttype(1:80),'(80a)') ' '
247                        write(weighttype(1:80),'(a)') "whflux"
248            write(cunit) ncvarindex(2)            call ctrl_set_pack_xy(
249            write(cunit) 1       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,
250            write(cunit) 1       &         lxxadxx, mythid)
251            do k = 1,nr  #endif
252             cbuffindex = 0  
253              do jp = 1,nPy  #if (defined (ALLOW_SFLUX_CONTROL) || \
254               do bj = jtlo,jthi       defined (ALLOW_SFLUX0_CONTROL))
255                do j = jmin,jmax            ivartype = 4
256                 do ip = 1,nPx            write(weighttype(1:80),'(80a)') ' '
257                  do bi = itlo,ithi            write(weighttype(1:80),'(a)') "wsflux"
258                   do i = imin,imax            call ctrl_set_pack_xy(
259                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,
260                         cbuffindex = cbuffindex + 1       &         lxxadxx, mythid)
261  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #endif
262                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
263       &                      * sqrt(wsalt(k,bi,bj))  #if (defined (ALLOW_USTRESS_CONTROL) || \
264  #else       defined (ALLOW_TAUU0_CONTROL))
265                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 5
266  #endif            write(weighttype(1:80),'(80a)') ' '
267                      endif            write(weighttype(1:80),'(a)') "wtauu"
268                   enddo            call ctrl_set_pack_xy(
269                  enddo       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,
270                 enddo       &         lxxadxx, mythid)
271                enddo  #endif
272               enddo  
273              enddo  #if (defined (ALLOW_VSTRESS_CONTROL) || \
274  c     --> check cbuffindex.       defined (ALLOW_TAUV0_CONTROL))
275              if ( cbuffindex .gt. 0) then            ivartype = 6
276                 write(cunit) cbuffindex            write(weighttype(1:80),'(80a)') ' '
277                 write(cunit) k            write(weighttype(1:80),'(a)') "wtauv"
278                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            call ctrl_set_pack_xy(
279              endif       &         cunit, ivartype, adfname_tauv, "maskS", weighttype,
280           enddo       &         lxxadxx, mythid)
281    #endif
282  #endif  
283    #ifdef ALLOW_ATEMP_CONTROL
284  #ifdef ALLOW_TR10_CONTROL            ivartype = 7
285              write(weighttype(1:80),'(80a)') ' '
286            il=ilnblnk( xx_tr1_file)            write(weighttype(1:80),'(a)') "watemp"
287            write(fname(1:80),'(80a)') ' '            call ctrl_set_pack_xy(
288            write(fname(1:80),'(3a,i10.10)')       &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,
289       &         yadmark,xx_tr1_file(1:il),'.',optimcycle       &         lxxadxx, mythid)
290    #endif
291            call MDSREADFIELD_3D_GL( fname,  
292       &                          prec, 'RL', Nr,  #ifdef ALLOW_AQH_CONTROL
293       &                          globfld3d,            ivartype = 8
294       &                          1,  mythid)            write(weighttype(1:80),'(80a)') ' '
295                        write(weighttype(1:80),'(a)') "waqh"
296            write(cunit) ncvarindex(9)            call ctrl_set_pack_xy(
297            write(cunit) 1       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,
298            write(cunit) 1       &         lxxadxx, mythid)
299            do k = 1,nr  #endif
300             cbuffindex = 0  
301              do jp = 1,nPy  #ifdef ALLOW_UWIND_CONTROL
302               do bj = jtlo,jthi            ivartype = 9
303                do j = jmin,jmax            write(weighttype(1:80),'(80a)') ' '
304                 do ip = 1,nPx            write(weighttype(1:80),'(a)') "wuwind"
305                  do bi = itlo,ithi            call ctrl_set_pack_xy(
306                   do i = imin,imax       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,
307                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then       &         lxxadxx, mythid)
308                         cbuffindex = cbuffindex + 1  #endif
309  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
310                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #ifdef ALLOW_VWIND_CONTROL
311  cph     &                      * sqrt(wtr1(k,bi,bj))            ivartype = 10
312  #else            write(weighttype(1:80),'(80a)') ' '
313                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            write(weighttype(1:80),'(a)') "wvwind"
314  #endif            call ctrl_set_pack_xy(
315                      endif       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,
316                   enddo       &         lxxadxx, mythid)
317                  enddo  #endif
318                 enddo  
319                enddo  #ifdef ALLOW_OBCSN_CONTROL
320               enddo            ivartype = 11
321              enddo            call ctrl_set_pack_xz(
322  c     --> check cbuffindex.       &         cunit, ivartype, adfname_obcsn, "maskobcsn",
323              if ( cbuffindex .gt. 0) then       &         wobcsn, lxxadxx, mythid)
324                 write(cunit) cbuffindex  #endif
325                 write(cunit) k  
326                 write(cunit) (cbuff(ii), ii=1,cbuffindex)  #ifdef ALLOW_OBCSS_CONTROL
327              endif            ivartype = 12
328           enddo            call ctrl_set_pack_xz(
329         &         cunit, ivartype, adfname_obcss, "maskobcss",
330  #endif       &         wobcss, lxxadxx, mythid)
331    #endif
332  #ifdef ALLOW_HFLUX0_CONTROL  
333    #ifdef ALLOW_OBCSW_CONTROL
334            il=ilnblnk( xx_hflux_file)            ivartype = 13
335            write(fname(1:80),'(80a)') ' '            call ctrl_set_pack_yz(
336            write(fname(1:80),'(3a,i10.10)')       &         cunit, ivartype, adfname_obcsw, "maskobcsw",
337       &         yadmark,xx_hflux_file(1:il),'.',optimcycle       &         wobcsw, lxxadxx, mythid)
338  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #endif
339            call MDSREADFIELD_2D_GL( "whflux",  
340       &                          prec, 'RL', 1,  #ifdef ALLOW_OBCSE_CONTROL
341       &                          globfld2d,            ivartype = 14
342       &                          1,  mythid)            call ctrl_set_pack_yz(
343  #endif       &         cunit, ivartype, adfname_obcse, "maskobcse",
344            call MDSREADFIELD_2D_GL( fname,       &         wobcse, lxxadxx, mythid)
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(3)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SFLUX0_CONTROL  
   
           il=ilnblnk( xx_sflux_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_sflux_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsflux",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(4)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUU0_CONTROL  
   
           il=ilnblnk( xx_tauu_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_tauu_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauu",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(5)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUV0_CONTROL  
   
           il=ilnblnk( xx_tauv_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_tauv_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauv",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(6)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SST0_CONTROL  
   
           il=ilnblnk( xx_sst_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_sst_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsst",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(7)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SSS0_CONTROL  
   
           il=ilnblnk( xx_sss_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_sss_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsss",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(8)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
345  #endif  #endif
346    
347  #ifdef ALLOW_DIFFKR_CONTROL  #ifdef ALLOW_DIFFKR_CONTROL
348              ivartype = 15
349            il=ilnblnk( xx_diffkr_file)            call ctrl_set_pack_xyz(
350            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_diffkr, "hFacC",
351            write(fname(1:80),'(3a,i10.10)')       &         wunit, lxxadxx, mythid)
      &         yadmark,xx_diffkr_file(1:il),'.',optimcycle  
   
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(9)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 cph     &                      * sqrt(wdiffkr(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
352  #endif  #endif
353    
354  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
355              ivartype = 16
356            il=ilnblnk( xx_kapgm_file)            call ctrl_set_pack_xyz(
357            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_kapgm, "hFacC",
358            write(fname(1:80),'(3a,i10.10)')       &         wunit, lxxadxx, mythid)
      &         yadmark,xx_kapgm_file(1:il),'.',optimcycle  
   
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(9)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 cph     &                      * sqrt(wkapgm(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
359  #endif  #endif
360    
361    #ifdef ALLOW_TR10_CONTROL
362              ivartype = 17
363              call ctrl_set_pack_xyz(
364         &         cunit, ivartype, adfname_tr1, "hFacC",
365         &         wunit, lxxadxx, mythid)
366    #endif
367    
368    cph(
369              print *, 'ph-nondim bef. vor 21'
370              print *, 'ph-nondim aft. vor 21'
371    cph)
372    #ifdef ALLOW_EFLUXY0_CONTROL
373              ivartype = 21
374              call ctrl_set_pack_xyz(
375         &         cunit, ivartype, adfname_efluxy, "hFacS",
376         &         wefluxy, lxxadxx, mythid)
377    #endif
378    
379    cph(
380              print *, 'ph-nondim bef. vor 22'
381              print *, 'ph-nondim aft. vor 22'
382    cph)
383    #ifdef ALLOW_EFLUXP0_CONTROL
384              ivartype = 22
385              call ctrl_set_pack_xyz(
386         &         cunit, ivartype, adfname_efluxp, "hFacV",
387         &         wefluxp, lxxadxx, mythid)
388    #endif
389    
390    cph(
391              print *, 'ph-nondim bef. ende'
392              print *, 'ph-nondim aft. ende'
393    cph)
394            close ( cunit )            close ( cunit )
395    
396            _END_MASTER( mythid )
397    
398        return        return
399        end        end
400    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
  ViewVC Help
Powered by ViewVC 1.1.22