/[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.1 by heimbach, Sun Mar 25 22:33:55 2001 UTC revision 1.7 by heimbach, Fri Mar 7 02:45:48 2003 UTC
# Line 1  Line 1 
 C $Header$  
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
4    CBOP
5    C     !ROUTINE: ctrl_pack
6    C     !INTERFACE:
7          subroutine ctrl_pack( myiter, mytime, mythid )
8    
9    C     !DESCRIPTION: \bv
10    c     *=================================================================
11    c     | SUBROUTINE ctrl_pack
12    c     | Pack the control vector
13    c     | * All control variable and adjoint variable fields are
14    c     |   read from disk.
15    c     | * Wet points are extracted, and elements are
16    c     |   normalized (optional)
17    c     | * A single control vector containing only (normalized
18    c     |   wet points is written to file.
19    c     *=================================================================
20    C     \ev
21    
22        subroutine ctrl_pack(  C     !USES:
      I                      myiter,  
      I                      mytime,  
      I                      mythid  
      &                    )  
   
 c     ==================================================================  
 c     SUBROUTINE ctrl_pack  
 c     ==================================================================  
 c  
 c     o Compress the control vector such that only ocean points are  
 c       written to file.  
 c  
 c     started: Christian Eckert eckert@mit.edu  10-Mar=2000  
 c  
 c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000  
 c              - Transferred some filename declarations  
 c                from here to namelist in ctrl_init  
 c    
 c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000  
 c              - single file name convention with or without  
 c                ALLOW_ECCO_OPTIMIZATION  
 c  
 c  
 c     ==================================================================  
 c     SUBROUTINE ctrl_pack  
 c     ==================================================================  
   
23        implicit none        implicit none
24    
25  c     == global variables ==  c     == global variables ==
# Line 40  c     == global variables == Line 29  c     == global variables ==
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"
38    #endif
39    
40  c     == routine arguments ==  c     == routine arguments ==
41    
42        integer myiter        integer myiter
# Line 51  c     == routine arguments == Line 45  c     == routine arguments ==
45    
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  
59    
60        logical doglobalread        logical doglobalread
61        logical ladinit        logical ladinit
62        integer cbuffindex        integer cbuffindex
63    
64        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 )  
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_sst
105          character*( 80) adfname_sst
106          character*( 80)   fname_sss
107          character*( 80) adfname_sss
108          character*( 80)   fname_hfacc
109          character*( 80) adfname_hfacc
110          character*( 80)   fname_efluxy
111          character*( 80) adfname_efluxy
112          character*( 80)   fname_efluxp
113          character*( 80) adfname_efluxp
114          character*( 80)   fname_bottomdrag
115          character*( 80) adfname_bottomdrag
116    
117        integer prec        logical lxxadxx
118    
119  c     == external ==  c     == external ==
120    
# Line 85  c     == external == Line 123  c     == external ==
123    
124  c     == end of interface ==  c     == end of interface ==
125    
126        prec           = precFloat64  #ifndef ALLOW_ECCO_OPTIMIZATION
127        tmpvar         = -9999. _d 0        optimcycle = 0
128    #endif
129    
130        jtlo = 1        tmpvar = -9999. _d 0
       jthi = nsy  
       itlo = 1  
       ithi = nsx  
       jmin = 1  
       jmax = sny  
       imin = 1  
       imax = snx  
131    
132  c--   Tiled files are used.  c--   Tiled files are used.
133        doglobalread = .false.        doglobalread = .false.
# Line 103  c--   Tiled files are used. Line 135  c--   Tiled files are used.
135  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
136        ladinit = .false.        ladinit = .false.
137    
138  c  c--   Assign file names.
 c--   Only the master thread will do I/O.  
       _BEGIN_MASTER( mythid )  
139    
140  c--   read global mask file        call ctrl_set_fname(
141            call MDSREADFIELD_3D_GL( "hFacC",       I     xx_theta_file, fname_theta, adfname_theta, mythid )
142       &                           prec, 'RL', Nr, globmsk,        call ctrl_set_fname(
143       &                           1,  mythid)       I     xx_salt_file, fname_salt, adfname_salt, mythid )
144          call ctrl_set_fname(
145         I     xx_hflux_file, fname_hflux, adfname_hflux, mythid )
146          call ctrl_set_fname(
147         I     xx_sflux_file, fname_sflux, adfname_sflux, mythid )
148          call ctrl_set_fname(
149         I     xx_tauu_file, fname_tauu, adfname_tauu, mythid )
150          call ctrl_set_fname(
151         I     xx_tauv_file, fname_tauv, adfname_tauv, mythid )
152          call ctrl_set_fname(
153         I     xx_atemp_file, fname_atemp, adfname_atemp, mythid )
154          call ctrl_set_fname(
155         I     xx_aqh_file, fname_aqh, adfname_aqh, mythid )
156          call ctrl_set_fname(
157         I     xx_uwind_file, fname_uwind, adfname_uwind, mythid )
158          call ctrl_set_fname(
159         I     xx_vwind_file, fname_vwind, adfname_vwind, mythid )
160          call ctrl_set_fname(
161         I     xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
162          call ctrl_set_fname(
163         I     xx_obcss_file, fname_obcss, adfname_obcss, mythid )
164          call ctrl_set_fname(
165         I     xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
166          call ctrl_set_fname(
167         I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )
168          call ctrl_set_fname(
169         I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
170          call ctrl_set_fname(
171         I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
172          call ctrl_set_fname(
173         I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )
174          call ctrl_set_fname(
175         I     xx_sst_file, fname_sst, adfname_sst, mythid )
176          call ctrl_set_fname(
177         I     xx_sss_file, fname_sss, adfname_sss, mythid )
178          call ctrl_set_fname(
179         I     xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )
180          call ctrl_set_fname(
181         I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
182          call ctrl_set_fname(
183         I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
184          call ctrl_set_fname(
185         I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag
186         I   , mythid )
187    
188    c
189    c--     Only the master thread will do I/O.
190          _BEGIN_MASTER( mythid )
191    
192  c     >>> Write control vector <<<  c     >>> Write control vector <<<
193    
194            call mdsfindunit( cunit, mythid )  cph   this part was removed since it's not necessary
195            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  
196    
           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)  
197    
           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_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  
   
   
           close ( cunit )  
   
         _END_MASTER( mythid )  
   
 c======================================================================  
   
 c--   read global mask file  
           call MDSREADFIELD_3D_GL( "hFacC",  
      &                           prec, 'RL', Nr, globmsk,  
      &                           1,  mythid)  
198    
199  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
200          lxxadxx = .FALSE.
201    
202            call mdsfindunit( cunit, mythid )            call mdsfindunit( cunit, mythid )
203            write(cfile(1:128),'(2a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
204       &    costname(1:9),'.opt',       &    costname(1:9),'_',yctrlid(1:10),'.opt',
205       &    optimcycle       &    optimcycle
206    
207            open( cunit, file   = cfile,            open( cunit, file   = cfile,
# Line 578  c     >>> Write gradient vector <<< Line 212  c     >>> Write gradient vector <<<
212  c--       Header information.  c--       Header information.
213            write(cunit) nvartype            write(cunit) nvartype
214            write(cunit) nvarlength            write(cunit) nvarlength
215            write(cunit) expId            write(cunit) yctrlid
216            write(cunit) optimCycle            write(cunit) optimCycle
217            write(cunit) fc            write(cunit) fc
218            write(cunit) 1            write(cunit) 1
219            write(cunit) 1            write(cunit) 1
220            write(cunit) 1            write(cunit) 1
221            write(cunit) 1            write(cunit) 1
222            write(cunit) (nWetcTile(1,1,k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
223            write(cunit) (nWetsTile(1,1,k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
224            write(cunit) (nWetwTile(1,1,k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
225    #ifdef ALLOW_CTRL_WETV
226              write(cunit) (nWetvGlobal(k), k=1,nr)
227    #endif
228    #ifdef ALLOW_OBCSN_CONTROL
229              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
230    #endif
231    #ifdef ALLOW_OBCSS_CONTROL
232              write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
233    #endif
234    #ifdef ALLOW_OBCSW_CONTROL
235              write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
236    #endif
237    #ifdef ALLOW_OBCSE_CONTROL
238              write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
239    #endif
240            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
241            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
242            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (nx,  i=1,maxcvars)
# Line 597  c--       Header information. Line 246  c--       Header information.
246            write(cunit)            write(cunit)
247    
248  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
249              ivartype = 1
250            il=ilnblnk( xx_theta_file)            call ctrl_set_pack_xyz(
251            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_theta, "hFacC",
252            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  
   
253  #endif  #endif
254    
255  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
256              ivartype = 2
257            il=ilnblnk( xx_salt_file)            call ctrl_set_pack_xyz(
258            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_salt, "hFacC",
259            write(fname(1:80),'(3a,i10.10)')       &         wsalt, lxxadxx, mythid)
260       &         yadmark,xx_salt_file(1:il),'.',optimcycle  #endif
261    
262            call MDSREADFIELD_3D_GL( fname,  #if (defined (ALLOW_HFLUX_CONTROL) || \
263       &                          prec, 'RL', Nr,       defined (ALLOW_HFLUX0_CONTROL))
264       &                          globfld3d,            ivartype = 3
265       &                          1,  mythid)            write(weighttype(1:80),'(80a)') ' '
266                        write(weighttype(1:80),'(a)') "whflux"
267            write(cunit) ncvarindex(2)            call ctrl_set_pack_xy(
268            write(cunit) 1       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,
269            write(cunit) 1       &         lxxadxx, mythid)
270            do k = 1,nr  #endif
271             cbuffindex = 0  
272              do jp = 1,nPy  #if (defined (ALLOW_SFLUX_CONTROL) || \
273               do bj = jtlo,jthi       defined (ALLOW_SFLUX0_CONTROL))
274                do j = jmin,jmax            ivartype = 4
275                 do ip = 1,nPx            write(weighttype(1:80),'(80a)') ' '
276                  do bi = itlo,ithi            write(weighttype(1:80),'(a)') "wsflux"
277                   do i = imin,imax            call ctrl_set_pack_xy(
278                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,
279                         cbuffindex = cbuffindex + 1       &         lxxadxx, mythid)
280  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #endif
281                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
282       &                      * sqrt(wsalt(k,bi,bj))  #if (defined (ALLOW_USTRESS_CONTROL) || \
283  #else       defined (ALLOW_TAUU0_CONTROL))
284                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 5
285  #endif            write(weighttype(1:80),'(80a)') ' '
286                      endif            write(weighttype(1:80),'(a)') "wtauu"
287                   enddo            call ctrl_set_pack_xy(
288                  enddo       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,
289                 enddo       &         lxxadxx, mythid)
290                enddo  #endif
291               enddo  
292              enddo  #if (defined (ALLOW_VSTRESS_CONTROL) || \
293  c     --> check cbuffindex.       defined (ALLOW_TAUV0_CONTROL))
294              if ( cbuffindex .gt. 0) then            ivartype = 6
295                 write(cunit) cbuffindex            write(weighttype(1:80),'(80a)') ' '
296                 write(cunit) k            write(weighttype(1:80),'(a)') "wtauv"
297                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            call ctrl_set_pack_xy(
298              endif       &         cunit, ivartype, adfname_tauv, "maskS", weighttype,
299           enddo       &         lxxadxx, mythid)
300    #endif
301  #endif  
302    #ifdef ALLOW_ATEMP_CONTROL
303              ivartype = 7
304  #ifdef ALLOW_HFLUX0_CONTROL            write(weighttype(1:80),'(80a)') ' '
305              write(weighttype(1:80),'(a)') "watemp"
306            il=ilnblnk( xx_hflux_file)            call ctrl_set_pack_xy(
307            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,
308            write(fname(1:80),'(3a,i10.10)')       &         lxxadxx, mythid)
309       &         yadmark,xx_hflux_file(1:il),'.',optimcycle  #endif
310  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
311            call MDSREADFIELD_2D_GL( "whflux",  #ifdef ALLOW_AQH_CONTROL
312       &                          prec, 'RL', 1,            ivartype = 8
313       &                          globfld2d,            write(weighttype(1:80),'(80a)') ' '
314       &                          1,  mythid)            write(weighttype(1:80),'(a)') "waqh"
315  #endif            call ctrl_set_pack_xy(
316            call MDSREADFIELD_2D_GL( fname,       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,
317       &                          prec, 'RL', 1,       &         lxxadxx, mythid)
318       &                          globfld3d(1,1,1,1,1,1,1),  #endif
319       &                          1,  mythid)  
320    #ifdef ALLOW_UWIND_CONTROL
321            write(cunit) ncvarindex(3)            ivartype = 9
322            write(cunit) 1            write(weighttype(1:80),'(80a)') ' '
323            write(cunit) 1            write(weighttype(1:80),'(a)') "wuwind"
324            k = 1            call ctrl_set_pack_xy(
325             cbuffindex = 0       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,
326              do jp = 1,nPy       &         lxxadxx, mythid)
327               do bj = jtlo,jthi  #endif
328                do j = jmin,jmax  
329                 do ip = 1,nPx  #ifdef ALLOW_VWIND_CONTROL
330                  do bi = itlo,ithi            ivartype = 10
331                   do i = imin,imax            write(weighttype(1:80),'(80a)') ' '
332                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            write(weighttype(1:80),'(a)') "wvwind"
333                         cbuffindex = cbuffindex + 1            call ctrl_set_pack_xy(
334  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,
335                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         lxxadxx, mythid)
336       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  #endif
337  #else  
338                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #ifdef ALLOW_OBCSN_CONTROL
339  #endif            ivartype = 11
340                      endif            call ctrl_set_pack_xz(
341                   enddo       &         cunit, ivartype, adfname_obcsn, "maskobcsn",
342                  enddo       &         wobcsn, lxxadxx, mythid)
343                 enddo  #endif
344                enddo  
345               enddo  #ifdef ALLOW_OBCSS_CONTROL
346              enddo            ivartype = 12
347  c     --> check cbuffindex.            call ctrl_set_pack_xz(
348              if ( cbuffindex .gt. 0) then       &         cunit, ivartype, adfname_obcss, "maskobcss",
349                 write(cunit) cbuffindex       &         wobcss, lxxadxx, mythid)
350                 write(cunit) k  #endif
351                 write(cunit) (cbuff(ii), ii=1,cbuffindex)  
352              endif  #ifdef ALLOW_OBCSW_CONTROL
353              ivartype = 13
354  #endif            call ctrl_set_pack_yz(
355         &         cunit, ivartype, adfname_obcsw, "maskobcsw",
356  #ifdef ALLOW_SFLUX0_CONTROL       &         wobcsw, lxxadxx, mythid)
357    #endif
358            il=ilnblnk( xx_sflux_file)  
359            write(fname(1:80),'(80a)') ' '  #ifdef ALLOW_OBCSE_CONTROL
360            write(fname(1:80),'(3a,i10.10)')            ivartype = 14
361       &         yadmark,xx_sflux_file(1:il),'.',optimcycle            call ctrl_set_pack_yz(
362  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, adfname_obcse, "maskobcse",
363            call MDSREADFIELD_2D_GL( "wsflux",       &         wobcse, lxxadxx, mythid)
364       &                          prec, 'RL', 1,  #endif
365       &                          globfld2d,  
366       &                          1,  mythid)  #ifdef ALLOW_DIFFKR_CONTROL
367  #endif            ivartype = 15
368            call MDSREADFIELD_2D_GL( fname,            call ctrl_set_pack_xyz(
369       &                          prec, 'RL', 1,       &         cunit, ivartype, adfname_diffkr, "hFacC",
370       &                          globfld3d(1,1,1,1,1,1,1),       &         wunit, lxxadxx, mythid)
371       &                          1,  mythid)  #endif
372    
373            write(cunit) ncvarindex(4)  #ifdef ALLOW_KAPGM_CONTROL
374            write(cunit) 1            ivartype = 16
375            write(cunit) 1            call ctrl_set_pack_xyz(
376            k = 1       &         cunit, ivartype, adfname_kapgm, "hFacC",
377             cbuffindex = 0       &         wunit, lxxadxx, mythid)
378              do jp = 1,nPy  #endif
379               do bj = jtlo,jthi  
380                do j = jmin,jmax  #ifdef ALLOW_TR10_CONTROL
381                 do ip = 1,nPx            ivartype = 17
382                  do bi = itlo,ithi            call ctrl_set_pack_xyz(
383                   do i = imin,imax       &         cunit, ivartype, adfname_tr1, "hFacC",
384                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then       &         wunit, lxxadxx, mythid)
                        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  
   
385  #endif  #endif
386    
387  #ifdef ALLOW_SST0_CONTROL  #ifdef ALLOW_SST0_CONTROL
388              ivartype = 18
389            il=ilnblnk( xx_sst_file)            write(weighttype(1:80),'(80a)') ' '
390            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsst0"
391            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
392       &         yadmark,xx_sst_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sst0, "hFacC", weighttype,
393  #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  
   
394  #endif  #endif
395    
396  #ifdef ALLOW_SSS0_CONTROL  #ifdef ALLOW_SSS0_CONTROL
397              ivartype = 19
398            il=ilnblnk( xx_sss_file)            write(weighttype(1:80),'(80a)') ' '
399            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsss0"
400            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
401       &         yadmark,xx_sss_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sss0, "hFacC", weighttype,
402  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         lxxadxx, mythid)
403            call MDSREADFIELD_2D_GL( "wsss",  #endif
404       &                          prec, 'RL', 1,  
405       &                          globfld2d,  #ifdef ALLOW_HFACC_CONTROL
406       &                          1,  mythid)            ivartype = 20
407  #endif  #ifdef ALLOW_HFACC3D_CONTROL
408            call MDSREADFIELD_2D_GL( fname,            call ctrl_set_pack_xyz(
409       &                          prec, 'RL', 1,       &         cunit, ivartype, adfname_hfacc, "hFacC",
410       &                          globfld3d(1,1,1,1,1,1,1),       &         wunit, lxxadxx, mythid)
411       &                          1,  mythid)  #else
412              write(weighttype(1:80),'(80a)') ' '
413            write(cunit) ncvarindex(8)            write(weighttype(1:80),'(a)') "whfacc"
414            write(cunit) 1            call ctrl_set_pack_xy(
415            write(cunit) 1       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,
416            k = 1       &         lxxadxx, mythid)
417             cbuffindex = 0  #endif
             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)  
418  #endif  #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  
419    
420    #ifdef ALLOW_EFLUXY0_CONTROL
421              ivartype = 21
422              call ctrl_set_pack_xyz(
423         &         cunit, ivartype, adfname_efluxy, "hFacS",
424         &         wunit, lxxadxx, mythid)
425    #endif
426    
427    #ifdef ALLOW_EFLUXP0_CONTROL
428              ivartype = 22
429              call ctrl_set_pack_xyz(
430         &         cunit, ivartype, adfname_efluxp, "hFacV",
431         &         wunit, lxxadxx, mythid)
432    #endif
433    
434    #ifdef ALLOW_BOTTOMDRAG_CONTROL
435              ivartype = 23
436              write(weighttype(1:80),'(80a)') ' '
437              write(weighttype(1:80),'(a)') "wbottomdrag"
438              call ctrl_set_pack_xy(
439         &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,
440         &         lxxadxx, mythid)
441  #endif  #endif
442    
443            close ( cunit )            close ( cunit )
444    
445            _END_MASTER( mythid )
446    
447        return        return
448        end        end
449    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.7
  ViewVC Help
Powered by ViewVC 1.1.22