Changeset 3294 for trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
- Timestamp:
- 2012-01-28T17:44:18+01:00 (12 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90 (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2777 r3294 20 20 USE geo2ocean ! for vector rotation on to model grid 21 21 USE lib_mpp ! MPP library 22 USE wrk_nemo ! work arrays 22 23 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar 23 24 24 25 IMPLICIT NONE 25 26 PRIVATE 27 28 PUBLIC fld_map ! routine called by tides_init 26 29 27 30 TYPE, PUBLIC :: FLD_N !: Namelist field informations … … 56 59 LOGICAL :: rotn ! flag to indicate whether field has been rotated 57 60 END TYPE FLD 61 62 TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays 63 INTEGER, POINTER :: ptr(:) 64 END TYPE MAP_POINTER 58 65 59 66 !$AGRIF_DO_NOT_TREAT … … 98 105 CONTAINS 99 106 100 SUBROUTINE fld_read( kt, kn_fsbc, sd )107 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, jit, time_offset ) 101 108 !!--------------------------------------------------------------------- 102 109 !! *** ROUTINE fld_read *** … … 113 120 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 114 121 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 122 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping index 123 INTEGER , INTENT(in ), OPTIONAL :: jit ! subcycle timestep for timesplitting option 124 INTEGER , INTENT(in ), OPTIONAL :: time_offset ! provide fields at time other than "now" 125 ! time_offset = -1 => fields at "before" time level 126 ! time_offset = +1 => fields at "after" time levels 127 ! etc. 115 128 !! 116 129 INTEGER :: imf ! size of the structure sd … … 119 132 INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend 120 133 INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step 134 INTEGER :: itime_add ! local time offset variable 121 135 LOGICAL :: llnxtyr ! open next year file? 122 136 LOGICAL :: llnxtmth ! open next month file? 123 137 LOGICAL :: llstop ! stop is the file does not exist 138 LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields 124 139 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 125 140 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation 126 141 CHARACTER(LEN=1000) :: clfmt ! write format 127 142 !!--------------------------------------------------------------------- 143 ll_firstcall = .false. 144 IF( PRESENT(jit) ) THEN 145 IF(kt == nit000 .and. jit == 1) ll_firstcall = .true. 146 ELSE 147 IF(kt == nit000) ll_firstcall = .true. 148 ENDIF 149 150 itime_add = 0 151 IF( PRESENT(time_offset) ) itime_add = time_offset 152 128 153 ! 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 154 IF( present(jit) ) THEN 155 ! ignore kn_fsbc in this case 156 isecsbc = nsec_year + nsec1jan000 + (jit+itime_add)*rdt/REAL(nn_baro,wp) 157 ELSE 158 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) + itime_add * rdttra(1) ! middle of sbc time step 159 ENDIF 130 160 imf = SIZE( sd ) 131 161 ! 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 162 IF( ll_firstcall ) THEN ! initialization 163 IF( PRESENT(map) ) THEN 164 DO jf = 1, imf 165 CALL fld_init( kn_fsbc, sd(jf), map(jf)%ptr ) ! read each before field (put them in after as they will be swapped) 166 END DO 167 ELSE 168 DO jf = 1, imf 169 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 170 END DO 171 ENDIF 136 172 IF( lwp ) CALL wgt_print() ! control print 137 173 CALL fld_rot( kt, sd ) ! rotate vector fiels if needed … … 143 179 DO jf = 1, imf ! --- loop over field --- ! 144 180 145 IF( isecsbc > sd(jf)%nrec_a(2) .OR. kt == nit000) THEN ! read/update the after data?181 IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? 146 182 147 183 IF( sd(jf)%ln_tint ) THEN ! swap before record field and informations … … 151 187 ENDIF 152 188 153 CALL fld_rec( kn_fsbc, sd(jf) ) ! update record informations 189 IF( PRESENT(jit) ) THEN 190 CALL fld_rec( kn_fsbc, sd(jf), time_offset=itime_add, jit=jit ) ! update record informations 191 ELSE 192 CALL fld_rec( kn_fsbc, sd(jf), time_offset=itime_add ) ! update record informations 193 ENDIF 154 194 155 195 ! do we have to change the year/month/week/day of the forcing field?? … … 212 252 213 253 ! read after data 214 CALL fld_get( sd(jf) ) 254 IF( PRESENT(map) ) THEN 255 CALL fld_get( sd(jf), map(jf)%ptr ) 256 ELSE 257 CALL fld_get( sd(jf) ) 258 ENDIF 215 259 216 260 ENDIF … … 225 269 clfmt = "('fld_read: var ', a, ' kt = ', i8, ' (', f7.2,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & 226 270 & "', 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, & 271 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 228 272 & 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 273 WRITE(numout, *) 'itime_add is : ',itime_add 229 274 ENDIF 230 275 ! temporal interpolation weights … … 253 298 254 299 255 SUBROUTINE fld_init( kn_fsbc, sdjf )300 SUBROUTINE fld_init( kn_fsbc, sdjf, map ) 256 301 !!--------------------------------------------------------------------- 257 302 !! *** ROUTINE fld_init *** … … 262 307 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 263 308 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 309 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 264 310 !! 265 311 LOGICAL :: llprevyr ! are we reading previous year file? … … 364 410 365 411 ! read before data 366 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 412 IF( PRESENT(map) ) THEN 413 CALL fld_get( sdjf, map ) ! read before values in after arrays(as we will swap it later) 414 ELSE 415 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 416 ENDIF 367 417 368 418 clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i4, ' at time = ', f7.2, ' days')" … … 396 446 397 447 398 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore )448 SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, jit, time_offset ) 399 449 !!--------------------------------------------------------------------- 400 450 !! *** ROUTINE fld_rec *** … … 410 460 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 411 461 LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.) 462 INTEGER , INTENT(in ), OPTIONAL :: jit ! index of barotropic subcycle 412 463 ! used only if sdjf%ln_tint = .TRUE. 464 INTEGER , INTENT(in ), OPTIONAL :: time_offset ! Offset of required time level compared to "now" 465 ! time level in units of time steps. 413 466 !! 414 467 LOGICAL :: llbefore ! local definition of ldbefore … … 417 470 INTEGER :: ifreq_sec ! frequency mean (in seconds) 418 471 INTEGER :: isec_week ! number of seconds since the start of the weekly file 472 INTEGER :: itime_add ! local time offset variable 419 473 REAL(wp) :: ztmp ! temporary variable 420 474 !!---------------------------------------------------------------------- … … 425 479 ELSE ; llbefore = .FALSE. 426 480 ENDIF 481 ! 482 itime_add = 0 483 IF( PRESENT(time_offset) ) itime_add = time_offset 427 484 ! 428 485 ! ! =========== ! … … 443 500 ! 444 501 ztmp = REAL( nday, wp ) / REAL( nyear_len(1), wp ) + 0.5 502 IF( PRESENT(jit) ) THEN 503 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 504 ELSE 505 ztmp = ztmp + itime_add*rdttra(1) 506 ENDIF 445 507 sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 446 508 ! swap at the middle of the year … … 471 533 ! 472 534 ztmp = REAL( nday, wp ) / REAL( nmonth_len(nmonth), wp ) + 0.5 535 IF( PRESENT(jit) ) THEN 536 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 537 ELSE 538 ztmp = ztmp + itime_add*rdttra(1) 539 ENDIF 473 540 imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 474 541 IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) … … 498 565 ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdttra(1) ! shift time to be centrered in the middle of sbc time step 499 566 ztmp = ztmp + 0.01 * rdttra(1) ! add 0.01 time step to avoid truncation error 567 IF( PRESENT(jit) ) THEN 568 ztmp = ztmp + (jit+itime_add)*rdt/REAL(nn_baro,wp) 569 ELSE 570 ztmp = ztmp + itime_add*rdttra(1) 571 ENDIF 500 572 IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record 501 573 ! … … 546 618 547 619 548 SUBROUTINE fld_get( sdjf )549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE fld_ clopn***620 SUBROUTINE fld_get( sdjf, map ) 621 !!--------------------------------------------------------------------- 622 !! *** ROUTINE fld_get *** 551 623 !! 552 624 !! ** Purpose : read the data 553 625 !!---------------------------------------------------------------------- 554 626 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 627 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 555 628 !! 556 629 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 559 632 560 633 ipk = SIZE( sdjf%fnow, 3 ) 561 IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 634 635 IF( PRESENT(map) ) THEN 636 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 637 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 638 ENDIF 639 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 562 640 CALL wgt_list( sdjf, iw ) 563 641 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) … … 581 659 END SUBROUTINE fld_get 582 660 661 SUBROUTINE fld_map( num, clvar, dta, nrec, map ) 662 !!--------------------------------------------------------------------- 663 !! *** ROUTINE fld_get *** 664 !! 665 !! ** Purpose : read global data from file and map onto local data 666 !! using a general mapping (for open boundaries) 667 !!---------------------------------------------------------------------- 668 #if defined key_bdy 669 USE bdy_oce, ONLY: dta_global ! workspace to read in global data arrays 670 #endif 671 672 INTEGER , INTENT(in ) :: num ! stream number 673 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 674 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 675 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 676 INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices 677 !! 678 INTEGER :: ipi ! length of boundary data on local process 679 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 680 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 681 INTEGER :: ilendta ! length of data in file 682 INTEGER :: idvar ! variable ID 683 INTEGER :: ib, ik ! loop counters 684 INTEGER :: ierr 685 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 686 !!--------------------------------------------------------------------- 687 688 #if defined key_bdy 689 dta_read => dta_global 690 #endif 691 692 ipi = SIZE( dta, 1 ) 693 ipj = 1 694 ipk = SIZE( dta, 3 ) 695 696 idvar = iom_varid( num, clvar ) 697 ilendta = iom_file(num)%dimsz(1,idvar) 698 IF(lwp) WRITE(numout,*) 'Dim size for ',TRIM(clvar),' is ', ilendta 699 IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 700 701 SELECT CASE( ipk ) 702 CASE(1) 703 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1 ), nrec ) 704 CASE DEFAULT 705 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec ) 706 END SELECT 707 ! 708 DO ib = 1, ipi 709 DO ik = 1, ipk 710 dta(ib,1,ik) = dta_read(map(ib),1,ik) 711 END DO 712 END DO 713 714 END SUBROUTINE fld_map 715 583 716 584 717 SUBROUTINE fld_rot( kt, sd ) 585 718 !!--------------------------------------------------------------------- 586 !! *** ROUTINE fld_ clopn***719 !! *** ROUTINE fld_rot *** 587 720 !! 588 721 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction 589 722 !!---------------------------------------------------------------------- 590 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released591 USE wrk_nemo, ONLY: utmp => wrk_2d_4, vtmp => wrk_2d_5 ! 2D workspace592 !!593 723 INTEGER , INTENT(in ) :: kt ! ocean time step 594 724 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 595 725 !! 596 INTEGER :: ju, jv, jk ! loop indices 597 INTEGER :: imf ! size of the structure sd 598 INTEGER :: ill ! character length 599 INTEGER :: iv ! indice of V component 600 CHARACTER (LEN=100) :: clcomp ! dummy weight name 601 !!--------------------------------------------------------------------- 602 603 IF(wrk_in_use(2, 4,5) ) THEN 604 CALL ctl_stop('fld_rot: ERROR: requested workspace arrays are unavailable.') ; RETURN 605 END IF 726 INTEGER :: ju, jv, jk ! loop indices 727 INTEGER :: imf ! size of the structure sd 728 INTEGER :: ill ! character length 729 INTEGER :: iv ! indice of V component 730 REAL(wp), POINTER, DIMENSION(:,:) :: utmp, vtmp ! temporary arrays for vector rotation 731 CHARACTER (LEN=100) :: clcomp ! dummy weight name 732 !!--------------------------------------------------------------------- 733 734 CALL wrk_alloc( jpi,jpj, utmp, vtmp ) 606 735 607 736 !! (sga: following code should be modified so that pairs arent searched for each time … … 638 767 END DO 639 768 ! 640 IF(wrk_not_released(2, 4,5) ) CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.')769 CALL wrk_dealloc( jpi,jpj, utmp, vtmp ) 641 770 ! 642 771 END SUBROUTINE fld_rot … … 672 801 ! 673 802 CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) 674 803 ! 675 804 END SUBROUTINE fld_clopn 676 805 … … 805 934 !! file, restructuring as required 806 935 !!---------------------------------------------------------------------- 807 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released808 USE wrk_nemo, ONLY: data_tmp => wrk_2d_1 ! 2D real workspace809 USE wrk_nemo, ONLY: data_src => iwrk_2d_1 ! 2D integer workspace810 !!811 936 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 812 937 !! 813 INTEGER :: jn ! dummy loop indices 814 INTEGER :: inum ! temporary logical unit 815 INTEGER :: id ! temporary variable id 816 INTEGER :: ipk ! temporary vertical dimension 817 CHARACTER (len=5) :: aname 818 INTEGER , DIMENSION(3) :: ddims 819 LOGICAL :: cyclical 820 INTEGER :: zwrap ! local integer 821 !!---------------------------------------------------------------------- 822 ! 823 IF( wrk_in_use(2, 1) .OR. iwrk_in_use(2,1) ) THEN 824 CALL ctl_stop('fld_weight: requested workspace arrays are unavailable') ; RETURN 825 ENDIF 938 INTEGER :: jn ! dummy loop indices 939 INTEGER :: inum ! temporary logical unit 940 INTEGER :: id ! temporary variable id 941 INTEGER :: ipk ! temporary vertical dimension 942 CHARACTER (len=5) :: aname 943 INTEGER , DIMENSION(3) :: ddims 944 INTEGER , POINTER, DIMENSION(:,:) :: data_src 945 REAL(wp), POINTER, DIMENSION(:,:) :: data_tmp 946 LOGICAL :: cyclical 947 INTEGER :: zwrap ! local integer 948 !!---------------------------------------------------------------------- 949 ! 950 CALL wrk_alloc( jpi,jpj, data_src ) ! integer 951 CALL wrk_alloc( jpi,jpj, data_tmp ) 826 952 ! 827 953 IF( nxt_wgt > tot_wgts ) THEN … … 935 1061 ENDIF 936 1062 937 IF( wrk_not_released(2, 1) .OR. &938 iwrk_not_released(2, 1) ) CALL ctl_stop('fld_weight: failed to release workspace arrays')1063 CALL wrk_dealloc( jpi,jpj, data_src ) ! integer 1064 CALL wrk_dealloc( jpi,jpj, data_tmp ) 939 1065 ! 940 1066 END SUBROUTINE fld_weight
Note: See TracChangeset
for help on using the changeset viewer.
