/[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.2 by heimbach, Fri Jul 13 13:40:17 2001 UTC revision 1.9 by heimbach, Thu Jul 24 22:00:18 2003 UTC
# Line 1  Line 1 
 C $Header$  
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
# Line 26  c              Patrick Heimbach heimbach Line 25  c              Patrick Heimbach heimbach
25  c              - single file name convention with or without  c              - single file name convention with or without
26  c                ALLOW_ECCO_OPTIMIZATION  c                ALLOW_ECCO_OPTIMIZATION
27  c  c
28    c              G. Gebbie, added open boundary control packing,
29    c                  gebbie@mit.edu  18 -Mar- 2003
30  c  c
31  c     ==================================================================  c     ==================================================================
32  c     SUBROUTINE ctrl_pack  c     SUBROUTINE ctrl_pack
# Line 40  c     == global variables == Line 41  c     == global variables ==
41  #include "PARAMS.h"  #include "PARAMS.h"
42  #include "GRID.h"  #include "GRID.h"
43    
44    #include "ecco.h"
45  #include "ctrl.h"  #include "ctrl.h"
46  #include "cost.h"  #include "cost.h"
47    
48    #ifdef ALLOW_ECCO_OPTIMIZATION
49  #include "optim.h"  #include "optim.h"
50    #endif
51    
52  c     == routine arguments ==  c     == routine arguments ==
53    
# Line 52  c     == routine arguments == Line 57  c     == routine arguments ==
57    
58  c     == local variables ==  c     == local variables ==
59    
60        integer bi,bj  #ifndef ALLOW_ECCO_OPTIMIZATION
61        integer ip,jp        integer optimcycle
62        integer i,j,k  #endif
63    
64          integer i, j, k
65        integer ii        integer ii
66        integer il        integer il
67        integer irec        integer irec
68        integer itlo,ithi        integer ig,jg
69        integer jtlo,jthi        integer ivartype
70        integer jmin,jmax        integer iobcs
       integer imin,imax  
71    
72        logical doglobalread        logical doglobalread
73        logical ladinit        logical ladinit
74        integer cbuffindex        integer cbuffindex
75    
76        integer cunit        integer cunit
       _RL     cbuff( snx*nsx*npx*sny*nsy*npy )  
       _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 )  
77        _RL     tmpvar        _RL     tmpvar
78    
79        character*(128) cfile        character*(128) cfile
80        character*( 80) fname        character*( 80) weighttype
81    
82          character*( 80) fname_theta
83          character*( 80) fname_salt
84          character*( 80) fname_hflux
85          character*( 80) fname_sflux
86          character*( 80) fname_tauu
87          character*( 80) fname_tauv
88          character*( 80) adfname_theta
89          character*( 80) adfname_salt
90          character*( 80) adfname_hflux
91          character*( 80) adfname_sflux
92          character*( 80) adfname_tauu
93          character*( 80) adfname_tauv
94          character*( 80)   fname_atemp
95          character*( 80) adfname_atemp
96          character*( 80)   fname_aqh
97          character*( 80) adfname_aqh
98          character*( 80)   fname_uwind
99          character*( 80) adfname_uwind
100          character*( 80)   fname_vwind
101          character*( 80) adfname_vwind
102          character*( 80)   fname_obcsn
103          character*( 80) adfname_obcsn
104          character*( 80)   fname_obcss
105          character*( 80) adfname_obcss
106          character*( 80)   fname_obcsw
107          character*( 80) adfname_obcsw
108          character*( 80)   fname_obcse
109          character*( 80) adfname_obcse
110          character*( 80)   fname_diffkr
111          character*( 80) adfname_diffkr
112          character*( 80)   fname_kapgm
113          character*( 80) adfname_kapgm
114          character*( 80)   fname_tr1
115          character*( 80) adfname_tr1
116          character*( 80)   fname_sst
117          character*( 80) adfname_sst
118          character*( 80)   fname_sss
119          character*( 80) adfname_sss
120          character*( 80)   fname_hfacc
121          character*( 80) adfname_hfacc
122          character*( 80)   fname_efluxy
123          character*( 80) adfname_efluxy
124          character*( 80)   fname_efluxp
125          character*( 80) adfname_efluxp
126          character*( 80)   fname_bottomdrag
127          character*( 80) adfname_bottomdrag
128    
129        integer prec        logical lxxadxx
130    
131  c     == external ==  c     == external ==
132    
# Line 86  c     == external == Line 135  c     == external ==
135    
136  c     == end of interface ==  c     == end of interface ==
137    
138        prec           = precFloat64  #ifndef ALLOW_ECCO_OPTIMIZATION
139        tmpvar         = -9999. _d 0        optimcycle = 0
140    #endif
141    
142        jtlo = 1        tmpvar = -9999. _d 0
       jthi = nsy  
       itlo = 1  
       ithi = nsx  
       jmin = 1  
       jmax = sny  
       imin = 1  
       imax = snx  
143    
144  c--   Tiled files are used.  c--   Tiled files are used.
145        doglobalread = .false.        doglobalread = .false.
# Line 104  c--   Tiled files are used. Line 147  c--   Tiled files are used.
147  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
148        ladinit = .false.        ladinit = .false.
149    
150  c  c--   Assign file names.
 c--   Only the master thread will do I/O.  
       _BEGIN_MASTER( mythid )  
151    
152  c--   read global mask file        call ctrl_set_fname(
153            call MDSREADFIELD_3D_GL( "hFacC",       I     xx_theta_file, fname_theta, adfname_theta, mythid )
154       &                           prec, 'RL', Nr, globmsk,        call ctrl_set_fname(
155       &                           1,  mythid)       I     xx_salt_file, fname_salt, adfname_salt, mythid )
156          call ctrl_set_fname(
157         I     xx_hflux_file, fname_hflux, adfname_hflux, mythid )
158          call ctrl_set_fname(
159         I     xx_sflux_file, fname_sflux, adfname_sflux, mythid )
160          call ctrl_set_fname(
161         I     xx_tauu_file, fname_tauu, adfname_tauu, mythid )
162          call ctrl_set_fname(
163         I     xx_tauv_file, fname_tauv, adfname_tauv, mythid )
164          call ctrl_set_fname(
165         I     xx_atemp_file, fname_atemp, adfname_atemp, mythid )
166          call ctrl_set_fname(
167         I     xx_aqh_file, fname_aqh, adfname_aqh, mythid )
168          call ctrl_set_fname(
169         I     xx_uwind_file, fname_uwind, adfname_uwind, mythid )
170          call ctrl_set_fname(
171         I     xx_vwind_file, fname_vwind, adfname_vwind, mythid )
172          call ctrl_set_fname(
173         I     xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
174          call ctrl_set_fname(
175         I     xx_obcss_file, fname_obcss, adfname_obcss, mythid )
176          call ctrl_set_fname(
177         I     xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
178          call ctrl_set_fname(
179         I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )
180          call ctrl_set_fname(
181         I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
182          call ctrl_set_fname(
183         I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
184          call ctrl_set_fname(
185         I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )
186          call ctrl_set_fname(
187         I     xx_sst_file, fname_sst, adfname_sst, mythid )
188          call ctrl_set_fname(
189         I     xx_sss_file, fname_sss, adfname_sss, mythid )
190          call ctrl_set_fname(
191         I     xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )
192          call ctrl_set_fname(
193         I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
194          call ctrl_set_fname(
195         I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
196          call ctrl_set_fname(
197         I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag
198         I   , mythid )
199    
200    c
201    c--     Only the master thread will do I/O.
202          _BEGIN_MASTER( mythid )
203    
204  c     >>> Write control vector <<<  c     >>> Write control vector <<<
205    
206            call mdsfindunit( cunit, mythid )  cph   this part was removed since it's not necessary
207            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  
   
           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)  
   
           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  
208    
           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)  
209    
           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  
   
   
           close ( cunit )  
   
         _END_MASTER( mythid )  
   
 c======================================================================  
   
 c--   read global mask file  
           call MDSREADFIELD_3D_GL( "hFacC",  
      &                           prec, 'RL', Nr, globmsk,  
      &                           1,  mythid)  
210    
211  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
212          lxxadxx = .FALSE.
213    
214            call mdsfindunit( cunit, mythid )            call mdsfindunit( cunit, mythid )
215            write(cfile(1:128),'(2a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
216       &    costname(1:9),'.opt',       &    costname(1:9),'_',yctrlid(1:10),'.opt',
217       &    optimcycle       &    optimcycle
218    
219            open( cunit, file   = cfile,            open( cunit, file   = cfile,
# Line 625  c     >>> Write gradient vector <<< Line 224  c     >>> Write gradient vector <<<
224  c--       Header information.  c--       Header information.
225            write(cunit) nvartype            write(cunit) nvartype
226            write(cunit) nvarlength            write(cunit) nvarlength
227            write(cunit) expId            write(cunit) yctrlid
228            write(cunit) optimCycle            write(cunit) optimCycle
229            write(cunit) fc            write(cunit) fc
230            write(cunit) 1            write(cunit) 1
231            write(cunit) 1            write(cunit) 1
232            write(cunit) 1            write(cunit) 1
233            write(cunit) 1            write(cunit) 1
234            write(cunit) (nWetcTile(1,1,k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
235            write(cunit) (nWetsTile(1,1,k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
236            write(cunit) (nWetwTile(1,1,k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
237    #ifdef ALLOW_CTRL_WETV
238              write(cunit) (nWetvGlobal(k), k=1,nr)
239    #endif
240    #ifdef ALLOW_OBCSN_CONTROL
241              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
242    #endif
243    #ifdef ALLOW_OBCSS_CONTROL
244              write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
245    #endif
246    #ifdef ALLOW_OBCSW_CONTROL
247              write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
248    #endif
249    #ifdef ALLOW_OBCSE_CONTROL
250              write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
251    #endif
252            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
253            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
254            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (nx,  i=1,maxcvars)
# Line 644  c--       Header information. Line 258  c--       Header information.
258            write(cunit)            write(cunit)
259    
260  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
261              ivartype = 1
262            il=ilnblnk( xx_theta_file)            write(weighttype(1:80),'(80a)') ' '
263            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtheta"
264            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
265       &         yadmark,xx_theta_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_theta, "hFacC",
266         &         weighttype, wtheta, lxxadxx, mythid)
           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  
   
267  #endif  #endif
268    
269  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
270              ivartype = 2
271            il=ilnblnk( xx_salt_file)            write(weighttype(1:80),'(80a)') ' '
272            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsalt"
273            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
274       &         yadmark,xx_salt_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_salt, "hFacC",
275         &         weighttype, wsalt, lxxadxx, mythid)
276            call MDSREADFIELD_3D_GL( fname,  #endif
277       &                          prec, 'RL', Nr,  
278       &                          globfld3d,  #if (defined (ALLOW_HFLUX_CONTROL) || \
279       &                          1,  mythid)       defined (ALLOW_HFLUX0_CONTROL))
280                        ivartype = 3
281            write(cunit) ncvarindex(2)            write(weighttype(1:80),'(80a)') ' '
282            write(cunit) 1            write(weighttype(1:80),'(a)') "whflux"
283            write(cunit) 1            call ctrl_set_pack_xy(
284            do k = 1,nr       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,
285             cbuffindex = 0       &         lxxadxx, mythid)
286              do jp = 1,nPy  #endif
287               do bj = jtlo,jthi  
288                do j = jmin,jmax  #if (defined (ALLOW_SFLUX_CONTROL) || \
289                 do ip = 1,nPx       defined (ALLOW_SFLUX0_CONTROL))
290                  do bi = itlo,ithi            ivartype = 4
291                   do i = imin,imax            write(weighttype(1:80),'(80a)') ' '
292                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            write(weighttype(1:80),'(a)') "wsflux"
293                         cbuffindex = cbuffindex + 1            call ctrl_set_pack_xy(
294  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,
295                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         lxxadxx, mythid)
296       &                      * sqrt(wsalt(k,bi,bj))  #endif
297  #else  
298                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #if (defined (ALLOW_USTRESS_CONTROL) || \
299  #endif       defined (ALLOW_TAUU0_CONTROL))
300                      endif            ivartype = 5
301                   enddo            write(weighttype(1:80),'(80a)') ' '
302                  enddo            write(weighttype(1:80),'(a)') "wtauu"
303                 enddo            call ctrl_set_pack_xy(
304                enddo       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,
305               enddo       &         lxxadxx, mythid)
306              enddo  #endif
307  c     --> check cbuffindex.  
308              if ( cbuffindex .gt. 0) then  #if (defined (ALLOW_VSTRESS_CONTROL) || \
309                 write(cunit) cbuffindex       defined (ALLOW_TAUV0_CONTROL))
310                 write(cunit) k            ivartype = 6
311                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
312              endif            write(weighttype(1:80),'(a)') "wtauv"
313           enddo            call ctrl_set_pack_xy(
314         &         cunit, ivartype, adfname_tauv, "maskS", weighttype,
315         &         lxxadxx, mythid)
316    #endif
317    
318    #ifdef ALLOW_ATEMP_CONTROL
319              ivartype = 7
320              write(weighttype(1:80),'(80a)') ' '
321              write(weighttype(1:80),'(a)') "watemp"
322              call ctrl_set_pack_xy(
323         &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,
324         &         lxxadxx, mythid)
325    #endif
326    
327    #ifdef ALLOW_AQH_CONTROL
328              ivartype = 8
329              write(weighttype(1:80),'(80a)') ' '
330              write(weighttype(1:80),'(a)') "waqh"
331              call ctrl_set_pack_xy(
332         &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,
333         &         lxxadxx, mythid)
334    #endif
335    
336    #ifdef ALLOW_UWIND_CONTROL
337              ivartype = 9
338              write(weighttype(1:80),'(80a)') ' '
339              write(weighttype(1:80),'(a)') "wuwind"
340              call ctrl_set_pack_xy(
341         &         cunit, ivartype, adfname_uwind, "maskW", weighttype,
342         &         lxxadxx, mythid)
343    #endif
344    
345    #ifdef ALLOW_VWIND_CONTROL
346              ivartype = 10
347              write(weighttype(1:80),'(80a)') ' '
348              write(weighttype(1:80),'(a)') "wvwind"
349              call ctrl_set_pack_xy(
350         &         cunit, ivartype, adfname_vwind, "maskS", weighttype,
351         &         lxxadxx, mythid)
352    #endif
353    
354    #ifdef ALLOW_OBCSN_CONTROL
355              ivartype = 11
356              write(weighttype(1:80),'(80a)') ' '
357              write(weighttype(1:80),'(a)') "wobcsn"
358              call ctrl_set_pack_xz(
359         &         cunit, ivartype, adfname_obcsn, "maskobcsn",
360         &         weighttype, wobcsn, lxxadxx, mythid)
361    #endif
362    
363    #ifdef ALLOW_OBCSS_CONTROL
364              ivartype = 12
365              write(weighttype(1:80),'(80a)') ' '
366              write(weighttype(1:80),'(a)') "wobcss"
367              call ctrl_set_pack_xz(
368         &         cunit, ivartype, adfname_obcss, "maskobcss",
369         &         weighttype, wobcss, lxxadxx, mythid)
370    #endif
371    
372    #ifdef ALLOW_OBCSW_CONTROL
373              ivartype = 13
374              write(weighttype(1:80),'(80a)') ' '
375              write(weighttype(1:80),'(a)') "wobcsw"
376              call ctrl_set_pack_yz(
377         &         cunit, ivartype, adfname_obcsw, "maskobcsw",
378         &         weighttype, wobcsw, lxxadxx, mythid)
379    #endif
380    
381    #ifdef ALLOW_OBCSE_CONTROL
382              ivartype = 14
383              write(weighttype(1:80),'(80a)') ' '
384              write(weighttype(1:80),'(a)') "wobcse"
385              call ctrl_set_pack_yz(
386         &         cunit, ivartype, adfname_obcse, "maskobcse",
387         &         weighttype, wobcse, lxxadxx, mythid)
388    #endif
389    
390    #ifdef ALLOW_DIFFKR_CONTROL
391              ivartype = 15
392              write(weighttype(1:80),'(80a)') ' '
393              write(weighttype(1:80),'(a)') "wdiffkr"
394              call ctrl_set_pack_xyz(
395         &         cunit, ivartype, adfname_diffkr, "hFacC",
396         &         weighttype, wunit, lxxadxx, mythid)
397    #endif
398    
399    #ifdef ALLOW_KAPGM_CONTROL
400              ivartype = 16
401              write(weighttype(1:80),'(80a)') ' '
402              write(weighttype(1:80),'(a)') "wkapgm"
403              call ctrl_set_pack_xyz(
404         &         cunit, ivartype, adfname_kapgm, "hFacC",
405         &         weighttype, wunit, lxxadxx, mythid)
406  #endif  #endif
407    
408  #ifdef ALLOW_TR10_CONTROL  #ifdef ALLOW_TR10_CONTROL
409              ivartype = 17
410            il=ilnblnk( xx_tr1_file)            write(weighttype(1:80),'(80a)') ' '
411            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtr1"
412            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
413       &         yadmark,xx_tr1_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_tr1, "hFacC",
414         &         weighttype, wunit, lxxadxx, mythid)
           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(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),'(3a,i10.10)')  
      &         yadmark,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),'(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  
   
415  #endif  #endif
416    
417  #ifdef ALLOW_SST0_CONTROL  #ifdef ALLOW_SST0_CONTROL
418              ivartype = 18
419            il=ilnblnk( xx_sst_file)            write(weighttype(1:80),'(80a)') ' '
420            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsst0"
421            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
422       &         yadmark,xx_sst_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sst, "hFacC", weighttype,
423  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         lxxadxx, mythid)
           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  
   
424  #endif  #endif
425    
426  #ifdef ALLOW_SSS0_CONTROL  #ifdef ALLOW_SSS0_CONTROL
427              ivartype = 19
428            il=ilnblnk( xx_sss_file)            write(weighttype(1:80),'(80a)') ' '
429            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsss0"
430            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
431       &         yadmark,xx_sss_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sss, "hFacC", weighttype,
432  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         lxxadxx, mythid)
433            call MDSREADFIELD_2D_GL( "wsss",  #endif
434       &                          prec, 'RL', 1,  
435       &                          globfld2d,  #ifdef ALLOW_HFACC_CONTROL
436       &                          1,  mythid)            ivartype = 20
437  #endif            write(weighttype(1:80),'(80a)') ' '
438            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "whfacc"
439       &                          prec, 'RL', 1,  # ifdef ALLOW_HFACC3D_CONTROL
440       &                          globfld3d(1,1,1,1,1,1,1),            call ctrl_set_pack_xyz(
441       &                          1,  mythid)       &         cunit, ivartype, adfname_hfacc, "hFacC",
442         &         weighttype, wunit, lxxadxx, mythid)
443            write(cunit) ncvarindex(8)  # else
444            write(cunit) 1            call ctrl_set_pack_xy(
445            write(cunit) 1       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,
446            k = 1       &         lxxadxx, mythid)
447             cbuffindex = 0  # endif
448              do jp = 1,nPy  #endif
449               do bj = jtlo,jthi  
450                do j = jmin,jmax  #ifdef ALLOW_EFLUXY0_CONTROL
451                 do ip = 1,nPx            ivartype = 21
452                  do bi = itlo,ithi            write(weighttype(1:80),'(80a)') ' '
453                   do i = imin,imax            write(weighttype(1:80),'(a)') "wefluxy0"
454                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            call ctrl_set_pack_xyz(
455                         cbuffindex = cbuffindex + 1       &         cunit, ivartype, adfname_efluxy, "hFacS",
456  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
457                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
458       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
459  #else  #ifdef ALLOW_EFLUXP0_CONTROL
460                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 22
461  #endif            write(weighttype(1:80),'(80a)') ' '
462                      endif            write(weighttype(1:80),'(a)') "wefluxp0"
463                   enddo            call ctrl_set_pack_xyz(
464                  enddo       &         cunit, ivartype, adfname_efluxp, "hFacV",
465                 enddo       &         weighttype, wunit, lxxadxx, mythid)
466                enddo  #endif
467               enddo  
468              enddo  #ifdef ALLOW_BOTTOMDRAG_CONTROL
469  c     --> check cbuffindex.            ivartype = 23
470              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(80a)') ' '
471                 write(cunit) cbuffindex            write(weighttype(1:80),'(a)') "wbottomdrag"
472                 write(cunit) k            call ctrl_set_pack_xy(
473                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,
474              endif       &         lxxadxx, mythid)
   
475  #endif  #endif
476    
477            close ( cunit )            close ( cunit )
478    
479            _END_MASTER( mythid )
480    
481        return        return
482        end        end
483    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22