- Timestamp:
- 2011-11-09T11:47:32+01:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_UKM0_2011/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2777 r3062 24 24 IMPLICIT NONE 25 25 PRIVATE 26 27 PUBLIC fld_map ! routine called by tides_init 26 28 27 29 TYPE, PUBLIC :: FLD_N !: Namelist field informations … … 56 58 LOGICAL :: rotn ! flag to indicate whether field has been rotated 57 59 END TYPE FLD 60 61 TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays 62 INTEGER, POINTER :: ptr(:) 63 END TYPE MAP_POINTER 58 64 59 65 !$AGRIF_DO_NOT_TREAT … … 98 104 CONTAINS 99 105 100 SUBROUTINE fld_read( kt, kn_fsbc, sd )106 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, jit, time_offset ) 101 107 !!--------------------------------------------------------------------- 102 108 !! *** ROUTINE fld_read *** … … 113 119 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 114 120 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 121 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping index 122 INTEGER , INTENT(in ), OPTIONAL :: jit ! subcycle timestep for timesplitting option 123 INTEGER , INTENT(in ), OPTIONAL :: time_offset ! provide fields at time other than "now" 124 ! time_offset = -1 => fields at "before" time level 125 ! time_offset = +1 => fields at "after" time levels 126 ! etc. 115 127 !! 116 128 INTEGER :: imf ! size of the structure sd … … 119 131 INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend 120 132 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step 133 INTEGER :: time_add ! local time_offset variable 121 134 LOGICAL :: llnxtyr ! open next year file? 122 135 LOGICAL :: llnxtmth ! open next month file? 123 136 LOGICAL :: llstop ! stop is the file does not exist 137 LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields 124 138 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 125 139 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 126 140 CHARACTER(LEN=1000) :: clfmt ! write format 127 141 !!--------------------------------------------------------------------- 142 ll_firstcall = .false. 143 IF( PRESENT(jit) ) THEN 144 IF(kt == nit000 .and. jit == 1) ll_firstcall = .true. 145 ELSE 146 IF(kt == nit000) ll_firstcall = .true. 147 ENDIF 148 149 time_add = 0 150 IF( PRESENT(time_offset) ) THEN 151 time_add = time_offset 152 ENDIF 153 128 154 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 129 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) ! middle of sbc time step 155 IF( present(jit) ) THEN 156 ! ignore kn_fsbc in this case 157 isecsbc = nsec_year + nsec1jan000 + (jit+time_add)*rdt/REAL(nn_baro,wp) 158 ELSE 159 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) + time_add * rdttra(1) ! middle of sbc time step 160 ENDIF 130 161 imf = SIZE( sd ) 131 162 ! 132 IF( kt == nit000 ) THEN ! initialization 133 DO jf = 1, imf 134 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 135 END DO 163 IF( ll_firstcall ) THEN ! initialization 164 IF( PRESENT(map) ) THEN 165 DO jf = 1, imf 166 CALL fld_init( kn_fsbc, sd(jf), map(jf)%ptr ) ! read each before field (put them in after as they will be swapped) 167 END DO 168 ELSE 169 DO jf = 1, imf 170 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 171 END DO 172 ENDIF 136 173 IF( lwp ) CALL wgt_print() ! control print 137 174 CALL fld_rot( kt, sd ) ! rotate vector fiels if needed … … 143 180 DO jf = 1, imf ! --- loop over field --- ! 144 181 145 IF( isecsbc > sd(jf)%nrec_a(2) .OR. kt == nit000) THEN ! read/update the after data?182 IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? 146 183 147 184 IF( sd(jf)%ln_tint ) THEN ! swap before record field and informations … … 151 188 ENDIF 152 189 153 CALL fld_rec( kn_fsbc, sd(jf) ) ! update record informations 190 IF( PRESENT(jit) ) THEN 191 CALL fld_rec( kn_fsbc, sd(jf), jit=jit ) ! update record informations 192 ELSE 193 CALL fld_rec( kn_fsbc, sd(jf) ) ! update record informations 194 ENDIF 154 195 155 196 ! do we have to change the year/month/week/day of the forcing field?? … … 212 253 213 254 ! read after data 214 CALL fld_get( sd(jf) ) 255 IF( PRESENT(map) ) THEN 256 CALL fld_get( sd(jf), map(jf)%ptr ) 257 ELSE 258 CALL fld_get( sd(jf) ) 259 ENDIF 215 260 216 261 ENDIF … … 225 270 clfmt = "('fld_read: var ', a, ' kt = ', i8, ' (', f7.2,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & 226 271 & "', records b/a: ', i4.4, '/', i4.4, ' (days ', f7.2,'/', f7.2, ')')" 227 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 272 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 228 273 & sd(jf)%nrec_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday 274 WRITE(numout, *) 'time_add is : ',time_add 229 275 ENDIF 230 276 ! temporal interpolation weights … … 253 299 254 300 255 SUBROUTINE fld_init( kn_fsbc, sdjf )301 SUBROUTINE fld_init( kn_fsbc, sdjf, map ) 256 302 !!--------------------------------------------------------------------- 257 303 !! *** ROUTINE fld_init *** … … 262 308 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 263 309 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 310 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 264 311 !! 265 312 LOGICAL :: llprevyr ! are we reading previous year file? … … 364 411 365 412 ! read before data 366 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 413 IF( PRESENT(map) ) THEN 414 CALL fld_get( sdjf, map ) ! read before values in after arrays(as we will swap it later) 415 ELSE 416 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 417 ENDIF 367 418 368 419 clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i4, ' at time = ', f7.2, ' days')" … … 396 447 397 448 398 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore )449 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, jit ) 399 450 !!--------------------------------------------------------------------- 400 451 !! *** ROUTINE fld_rec *** … … 410 461 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 411 462 LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.) 463 INTEGER , INTENT(in ), OPTIONAL :: jit ! index of barotropic subcycle 412 464 ! used only if sdjf%ln_tint = .TRUE. 413 465 !! … … 443 495 ! 444 496 ztmp = REAL( nday, wp ) / REAL( nyear_len(1), wp ) + 0.5 497 IF( PRESENT(jit) ) ztmp = ztmp + jit*rdt/REAL(nn_baro,wp) 445 498 sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 446 499 ! swap at the middle of the year … … 471 524 ! 472 525 ztmp = REAL( nday, wp ) / REAL( nmonth_len(nmonth), wp ) + 0.5 526 IF( PRESENT(jit) ) ztmp = ztmp + jit*rdt/REAL(nn_baro,wp) 473 527 imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 474 528 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) … … 498 552 ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdttra(1) ! shift time to be centrered in the middle of sbc time step 499 553 ztmp = ztmp + 0.01 * rdttra(1) ! add 0.01 time step to avoid truncation error 554 IF( PRESENT(jit) ) ztmp = ztmp + jit*rdt/REAL(nn_baro,wp) 500 555 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 501 556 ! … … 546 601 547 602 548 SUBROUTINE fld_get( sdjf )549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE fld_ clopn***603 SUBROUTINE fld_get( sdjf, map ) 604 !!--------------------------------------------------------------------- 605 !! *** ROUTINE fld_get *** 551 606 !! 552 607 !! ** Purpose : read the data 553 608 !!---------------------------------------------------------------------- 554 609 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 610 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 555 611 !! 556 612 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 559 615 560 616 ipk = SIZE( sdjf%fnow, 3 ) 561 IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 617 618 IF( PRESENT(map) ) THEN 619 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 620 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 621 ENDIF 622 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 562 623 CALL wgt_list( sdjf, iw ) 563 624 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) … … 581 642 END SUBROUTINE fld_get 582 643 644 SUBROUTINE fld_map( num, clvar, dta, nrec, map ) 645 !!--------------------------------------------------------------------- 646 !! *** ROUTINE fld_get *** 647 !! 648 !! ** Purpose : read global data from file and map onto local data 649 !! using a general mapping (for open boundaries) 650 !!---------------------------------------------------------------------- 651 #if defined key_bdy 652 USE bdy_oce, ONLY: dta_global ! workspace to read in global data arrays 653 #endif 654 655 INTEGER , INTENT(in ) :: num ! stream number 656 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 657 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 658 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 659 INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices 660 !! 661 INTEGER :: ipi ! length of boundary data on local process 662 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 663 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 664 INTEGER :: ilendta ! length of data in file 665 INTEGER :: idvar ! variable ID 666 INTEGER :: ib, ik ! loop counters 667 INTEGER :: ierr 668 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 669 !!--------------------------------------------------------------------- 670 671 #if defined key_bdy 672 dta_read => dta_global 673 #endif 674 675 ipi = SIZE( dta, 1 ) 676 ipj = 1 677 ipk = SIZE( dta, 3 ) 678 679 idvar = iom_varid( num, clvar ) 680 ilendta = iom_file(num)%dimsz(1,idvar) 681 IF(lwp) WRITE(numout,*) 'Dim size for ',TRIM(clvar),' is ', ilendta 682 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 683 684 SELECT CASE( ipk ) 685 CASE(1) 686 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) 687 CASE DEFAULT 688 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec ) 689 END SELECT 690 ! 691 DO ib = 1, ipi 692 DO ik = 1, ipk 693 dta(ib,1,ik) = dta_read(map(ib),1,ik) 694 END DO 695 END DO 696 697 END SUBROUTINE fld_map 698 583 699 584 700 SUBROUTINE fld_rot( kt, sd ) 585 701 !!--------------------------------------------------------------------- 586 !! *** ROUTINE fld_ clopn***702 !! *** ROUTINE fld_rot *** 587 703 !! 588 704 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction 589 705 !!---------------------------------------------------------------------- 590 706 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 591 USE wrk_nemo, ONLY: utmp => wrk_2d_ 4, vtmp => wrk_2d_5 ! 2D workspace707 USE wrk_nemo, ONLY: utmp => wrk_2d_24, vtmp => wrk_2d_25 ! 2D workspace 592 708 !! 593 709 INTEGER , INTENT(in ) :: kt ! ocean time step … … 601 717 !!--------------------------------------------------------------------- 602 718 603 IF(wrk_in_use(2, 4,5) ) THEN719 IF(wrk_in_use(2, 24,25) ) THEN 604 720 CALL ctl_stop('fld_rot: ERROR: requested workspace arrays are unavailable.') ; RETURN 605 721 END IF … … 638 754 END DO 639 755 ! 640 IF(wrk_not_released(2, 4,5) ) CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.')756 IF(wrk_not_released(2, 24,25) ) CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.') 641 757 ! 642 758 END SUBROUTINE fld_rot … … 672 788 ! 673 789 CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) 674 790 ! 675 791 END SUBROUTINE fld_clopn 676 792
Note: See TracChangeset
for help on using the changeset viewer.
