/[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.4 by heimbach, Fri Sep 28 15:15:55 2001 UTC
# Line 2  C $Header$ Line 2  C $Header$
2    
3  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
4    
5    CBOP
6    C     !ROUTINE: ctrl_pack
7    C     !INTERFACE:
8          subroutine ctrl_pack( myiter, mytime, mythid )
9    
10    C     !DESCRIPTION: \bv
11    c     *=================================================================
12    c     | SUBROUTINE ctrl_pack
13    c     | Pack the control vector
14    c     | * All control variable and adjoint variable fields are
15    c     |   read from disk.
16    c     | * Wet points are extracted, and elements are
17    c     |   normalized (optional)
18    c     | * A single control vector containing only (normalized
19    c     |   wet points is written to file.
20    c     *=================================================================
21    C     \ev
22    
23        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     ==================================================================  
   
24        implicit none        implicit none
25    
26  c     == global variables ==  c     == global variables ==
   
27  #include "EEPARAMS.h"  #include "EEPARAMS.h"
28  #include "SIZE.h"  #include "SIZE.h"
29  #include "PARAMS.h"  #include "PARAMS.h"
30  #include "GRID.h"  #include "GRID.h"
   
31  #include "ctrl.h"  #include "ctrl.h"
32  #include "cost.h"  #include "cost.h"
33  #include "optim.h"  #include "optim.h"
34    
35    C     !INPUT/OUTPUT PARAMETERS:
36  c     == routine arguments ==  c     == routine arguments ==
   
37        integer myiter        integer myiter
38        _RL     mytime        _RL     mytime
39        integer mythid        integer mythid
40    
41    C     !LOCAL VARIABLES:
42  c     == local variables ==  c     == local variables ==
43    
44        integer bi,bj        integer bi,bj
# Line 62  c     == local variables == Line 51  c     == local variables ==
51        integer jtlo,jthi        integer jtlo,jthi
52        integer jmin,jmax        integer jmin,jmax
53        integer imin,imax        integer imin,imax
54          integer cbuffindex
55          integer cunit
56          integer prec
57    
58        logical doglobalread        logical doglobalread
59        logical ladinit        logical ladinit
       integer cbuffindex  
60    
       integer cunit  
61        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )
62        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
63        _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )        _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )
# Line 77  c     == local variables == Line 67  c     == local variables ==
67        character*(128) cfile        character*(128) cfile
68        character*( 80) fname        character*( 80) fname
69    
       integer prec  
   
70  c     == external ==  c     == external ==
   
71        integer  ilnblnk        integer  ilnblnk
72        external ilnblnk        external ilnblnk
73    
74  c     == end of interface ==  c     == end of interface ==
75    CEOP
76    
77        prec           = precFloat64        prec           = precFloat64
78        tmpvar         = -9999. _d 0        tmpvar         = -9999. _d 0
# Line 598  c     --> check cbuffindex. Line 586  c     --> check cbuffindex.
586    
587  #endif  #endif
588    
589    #ifdef ALLOW_DIFFKR_CONTROL
590    
591              il=ilnblnk( xx_diffkr_file)
592              write(fname(1:80),'(80a)') ' '
593              write(fname(1:80),'(2a,i10.10)')
594         &         xx_diffkr_file(1:il),'.',optimcycle
595              call MDSREADFIELD_3D_GL( fname,
596         &                          prec, 'RL', Nr, globfld3d,
597         &                          1,  mythid)
598    
599              write(cunit) ncvarindex(15)
600              write(cunit) 1
601              write(cunit) 1
602              do k = 1,nr
603               cbuffindex = 0
604                do jp = 1,nPy
605                 do bj = jtlo,jthi
606                  do j = jmin,jmax
607                   do ip = 1,nPx
608                    do bi = itlo,ithi
609                     do i = imin,imax
610                        if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then
611                           cbuffindex = cbuffindex + 1
612    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
613                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
614    cph     &                      * sqrt(wdiffkr(k,bi,bj))
615    #else
616                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
617    #endif
618                        endif
619                     enddo
620                    enddo
621                   enddo
622                  enddo
623                 enddo
624                enddo
625    c     --> check cbuffindex.
626                if ( cbuffindex .gt. 0) then
627                   write(cunit) cbuffindex
628                   write(cunit) k
629                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
630                endif
631             enddo
632                
633    #endif
634    
635    #ifdef ALLOW_KAPGM_CONTROL
636    
637              il=ilnblnk( xx_kapgm_file)
638              write(fname(1:80),'(80a)') ' '
639              write(fname(1:80),'(2a,i10.10)')
640         &         xx_kapgm_file(1:il),'.',optimcycle
641              call MDSREADFIELD_3D_GL( fname,
642         &                          prec, 'RL', Nr, globfld3d,
643         &                          1,  mythid)
644    
645              write(cunit) ncvarindex(16)
646              write(cunit) 1
647              write(cunit) 1
648              do k = 1,nr
649               cbuffindex = 0
650                do jp = 1,nPy
651                 do bj = jtlo,jthi
652                  do j = jmin,jmax
653                   do ip = 1,nPx
654                    do bi = itlo,ithi
655                     do i = imin,imax
656                        if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then
657                           cbuffindex = cbuffindex + 1
658    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
659                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
660    cph     &                      * sqrt(wkapgm(k,bi,bj))
661    #else
662                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
663    #endif
664                        endif
665                     enddo
666                    enddo
667                   enddo
668                  enddo
669                 enddo
670                enddo
671    c     --> check cbuffindex.
672                if ( cbuffindex .gt. 0) then
673                   write(cunit) cbuffindex
674                   write(cunit) k
675                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
676                endif
677             enddo
678                
679    #endif
680    
681            close ( cunit )            close ( cunit )
682    
# Line 1099  c     --> check cbuffindex. Line 1178  c     --> check cbuffindex.
1178    
1179  #endif  #endif
1180    
1181    #ifdef ALLOW_DIFFKR_CONTROL
1182    
1183              il=ilnblnk( xx_diffkr_file)
1184              write(fname(1:80),'(80a)') ' '
1185              write(fname(1:80),'(3a,i10.10)')
1186         &         yadmark,xx_diffkr_file(1:il),'.',optimcycle
1187    
1188              call MDSREADFIELD_3D_GL( fname,
1189         &                          prec, 'RL', Nr,
1190         &                          globfld3d,
1191         &                          1,  mythid)
1192              
1193              write(cunit) ncvarindex(9)
1194              write(cunit) 1
1195              write(cunit) 1
1196              do k = 1,nr
1197               cbuffindex = 0
1198                do jp = 1,nPy
1199                 do bj = jtlo,jthi
1200                  do j = jmin,jmax
1201                   do ip = 1,nPx
1202                    do bi = itlo,ithi
1203                     do i = imin,imax
1204                        if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then
1205                           cbuffindex = cbuffindex + 1
1206    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
1207                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
1208    cph     &                      * sqrt(wdiffkr(k,bi,bj))
1209    #else
1210                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
1211    #endif
1212                        endif
1213                     enddo
1214                    enddo
1215                   enddo
1216                  enddo
1217                 enddo
1218                enddo
1219    c     --> check cbuffindex.
1220                if ( cbuffindex .gt. 0) then
1221                   write(cunit) cbuffindex
1222                   write(cunit) k
1223                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
1224                endif
1225             enddo
1226    
1227    #endif
1228    
1229    #ifdef ALLOW_KAPGM_CONTROL
1230    
1231              il=ilnblnk( xx_kapgm_file)
1232              write(fname(1:80),'(80a)') ' '
1233              write(fname(1:80),'(3a,i10.10)')
1234         &         yadmark,xx_kapgm_file(1:il),'.',optimcycle
1235    
1236              call MDSREADFIELD_3D_GL( fname,
1237         &                          prec, 'RL', Nr,
1238         &                          globfld3d,
1239         &                          1,  mythid)
1240              
1241              write(cunit) ncvarindex(9)
1242              write(cunit) 1
1243              write(cunit) 1
1244              do k = 1,nr
1245               cbuffindex = 0
1246                do jp = 1,nPy
1247                 do bj = jtlo,jthi
1248                  do j = jmin,jmax
1249                   do ip = 1,nPx
1250                    do bi = itlo,ithi
1251                     do i = imin,imax
1252                        if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then
1253                           cbuffindex = cbuffindex + 1
1254    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
1255                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
1256    cph     &                      * sqrt(wkapgm(k,bi,bj))
1257    #else
1258                           cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
1259    #endif
1260                        endif
1261                     enddo
1262                    enddo
1263                   enddo
1264                  enddo
1265                 enddo
1266                enddo
1267    c     --> check cbuffindex.
1268                if ( cbuffindex .gt. 0) then
1269                   write(cunit) cbuffindex
1270                   write(cunit) k
1271                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
1272                endif
1273             enddo
1274    
1275    #endif
1276    
1277    
1278            close ( cunit )            close ( cunit )
1279    
1280        return        return
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.4
  ViewVC Help
Powered by ViewVC 1.1.22