Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
- Timestamp:
- 2011-03-30T17:58:35+02:00 (13 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90 (modified) (27 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2528 r2715 4 4 !! Ocean forcing: read input field for surface boundary condition 5 5 !!===================================================================== 6 !! History : 9.0 ! 06-06 (G. Madec) Original code7 !! ! 05- 08 (S. Alderson) Modified for Interpolation in memory8 !! ! from input grid to model grid6 !! History : 2.0 ! 06-2006 (S. Masson, G. Madec) Original code 7 !! ! 05-2008 (S. Alderson) Modified for Interpolation in memory 8 !! ! from input grid to model grid 9 9 !!---------------------------------------------------------------------- 10 10 … … 15 15 USE oce ! ocean dynamics and tracers 16 16 USE dom_oce ! ocean space and time domain 17 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar18 17 USE phycst ! ??? 19 18 USE in_out_manager ! I/O manager 20 19 USE iom ! I/O manager library 21 20 USE geo2ocean ! for vector rotation on to model grid 21 USE lib_mpp ! MPP library 22 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar 22 23 23 24 IMPLICIT NONE … … 33 34 CHARACTER(len = 34) :: wname ! generic name of a NetCDF weights file to be used, blank if not 34 35 CHARACTER(len = 34) :: vcomp ! symbolic component name if a vector that needs rotation 35 36 36 ! ! a string starting with "U" or "V" for each component 37 ! ! chars 2 onwards identify which components go together 37 38 END TYPE FLD_N 38 39 … … 51 52 REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields 52 53 CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key 53 54 ! ! into the WGTLIST structure 54 55 CHARACTER(len = 34) :: vcomp ! symbolic name for a vector component that needs rotation 55 56 LOGICAL :: rotn ! flag to indicate whether field has been rotated … … 65 66 INTEGER , DIMENSION(2) :: ddims ! shape of input grid 66 67 INTEGER , DIMENSION(2) :: botleft ! top left corner of box in input grid containing 67 68 ! ! current processor grid 68 69 INTEGER , DIMENSION(2) :: topright ! top right corner of box 69 70 INTEGER :: jpiwgt ! width of box on input grid … … 72 73 INTEGER :: nestid ! for agrif, keep track of nest we're in 73 74 INTEGER :: overlap ! =0 when cyclic grid has no overlapping EW columns 74 75 75 ! ! =>1 when they have one or more overlapping columns 76 ! ! =-1 not cyclic 76 77 LOGICAL :: cyclic ! east-west cyclic or not 77 78 INTEGER, DIMENSION(:,:,:), POINTER :: data_jpi ! array of source integers … … 93 94 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 94 95 !! $Id$ 95 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)96 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 96 97 !!---------------------------------------------------------------------- 97 98 98 CONTAINS 99 99 … … 259 259 !! ** Purpose : - if time interpolation, read before data 260 260 !! - open current year file 261 !!262 !! ** Method :263 261 !!---------------------------------------------------------------------- 264 262 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) … … 394 392 CALL fld_clopn( sdjf, iyear, imonth, iday ) 395 393 ENDIF 396 394 ! 397 395 END SUBROUTINE fld_init 398 396 … … 408 406 !! nrec_a(1): record number 409 407 !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only) 410 !!411 !! ** Method :412 408 !!---------------------------------------------------------------------- 413 409 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) … … 555 551 !! 556 552 !! ** Purpose : read the data 557 !! 558 !! ** Method : 559 !!---------------------------------------------------------------------- 560 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 561 !! 562 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 563 INTEGER :: iw ! index into wgts array 553 !!---------------------------------------------------------------------- 554 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 555 !! 556 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 557 INTEGER :: iw ! index into wgts array 564 558 !!--------------------------------------------------------------------- 565 559 … … 593 587 !! 594 588 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction 595 !! 596 !! ** Method : 597 !!---------------------------------------------------------------------- 589 !!---------------------------------------------------------------------- 590 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 591 USE wrk_nemo, ONLY: utmp => wrk_2d_4, vtmp => wrk_2d_5 ! 2D workspace 592 !! 598 593 INTEGER , INTENT(in ) :: kt ! ocean time step 599 594 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables … … 603 598 INTEGER :: ill ! character length 604 599 INTEGER :: iv ! indice of V component 605 REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation606 600 CHARACTER (LEN=100) :: clcomp ! dummy weight name 607 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 606 608 607 !! (sga: following code should be modified so that pairs arent searched for each time 609 608 ! … … 638 637 ENDIF 639 638 END DO 639 ! 640 IF(wrk_not_released(2, 4,5) ) CALL ctl_stop('fld_rot: ERROR: failed to release workspace arrays.') 641 ! 640 642 END SUBROUTINE fld_rot 641 643 … … 646 648 !! 647 649 !! ** Purpose : update the file name and open the file 648 !! 649 !! ** Method : 650 !!---------------------------------------------------------------------- 651 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 652 INTEGER , INTENT(in ) :: kyear ! year value 653 INTEGER , INTENT(in ) :: kmonth ! month value 654 INTEGER , INTENT(in ) :: kday ! day value 655 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 650 !!---------------------------------------------------------------------- 651 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables 652 INTEGER , INTENT(in ) :: kyear ! year value 653 INTEGER , INTENT(in ) :: kmonth ! month value 654 INTEGER , INTENT(in ) :: kday ! day value 655 LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 656 !!---------------------------------------------------------------------- 656 657 657 658 IF( sdjf%num /= 0 ) CALL iom_close( sdjf%num ) ! close file if already open … … 680 681 !! 681 682 !! ** Purpose : fill sdf with sdf_n and control print 682 !!683 !! ** Method :684 683 !!---------------------------------------------------------------------- 685 684 TYPE(FLD) , DIMENSION(:), INTENT(inout) :: sdf ! structure of input fields (file informations, fields read) … … 735 734 !! if it is a new entry, the weights data is read in and 736 735 !! restructured (fld_weight) 737 !! 738 !! ** Method : 739 !!---------------------------------------------------------------------- 740 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 741 INTEGER, INTENT(inout) :: kwgt ! index of weights 742 !! 743 INTEGER :: kw 744 INTEGER :: nestid 745 LOGICAL :: found 736 !!---------------------------------------------------------------------- 737 TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file 738 INTEGER , INTENT(inout) :: kwgt ! index of weights 739 !! 740 INTEGER :: kw, nestid ! local integer 741 LOGICAL :: found ! local logical 746 742 !!---------------------------------------------------------------------- 747 743 ! … … 769 765 CALL fld_weight( sd ) 770 766 ENDIF 771 767 ! 772 768 END SUBROUTINE wgt_list 773 769 770 774 771 SUBROUTINE wgt_print( ) 775 772 !!--------------------------------------------------------------------- … … 777 774 !! 778 775 !! ** Purpose : print the list of known weights 779 !! 780 !! ** Method : 781 !!---------------------------------------------------------------------- 782 !! 783 INTEGER :: kw 784 !!---------------------------------------------------------------------- 785 ! 786 776 !!---------------------------------------------------------------------- 777 INTEGER :: kw ! 778 !!---------------------------------------------------------------------- 779 ! 787 780 DO kw = 1, nxt_wgt-1 788 781 WRITE(numout,*) 'weight file: ',TRIM(ref_wgts(kw)%wgtname) … … 801 794 IF( ASSOCIATED(ref_wgts(kw)%data_wgt) ) WRITE(numout,*) ' allocated' 802 795 END DO 803 796 ! 804 797 END SUBROUTINE wgt_print 798 805 799 806 800 SUBROUTINE fld_weight( sd ) … … 810 804 !! ** Purpose : create a new WGT structure and fill in data from 811 805 !! file, restructuring as required 812 !! 813 !! ** Method : 814 !!---------------------------------------------------------------------- 815 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 816 !! 817 INTEGER :: jn ! dummy loop indices 818 INTEGER :: inum ! temporary logical unit 819 INTEGER :: id ! temporary variable id 820 INTEGER :: ipk ! temporary vertical dimension 821 CHARACTER (len=5) :: aname 822 INTEGER , DIMENSION(3) :: ddims 823 INTEGER , DIMENSION(jpi, jpj) :: data_src 824 REAL(wp), DIMENSION(jpi, jpj) :: data_tmp 825 LOGICAL :: cyclical 826 INTEGER :: zwrap ! temporary integer 827 !!---------------------------------------------------------------------- 806 !!---------------------------------------------------------------------- 807 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released 808 USE wrk_nemo, ONLY: data_tmp => wrk_2d_1 ! 2D real workspace 809 USE wrk_nemo, ONLY: data_src => iwrk_2d_1 ! 2D integer workspace 810 !! 811 TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file 812 !! 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_weights: requested workspace arrays are unavailable') ; RETURN 825 ENDIF 828 826 ! 829 827 IF( nxt_wgt > tot_wgts ) THEN … … 937 935 ENDIF 938 936 937 IF( wrk_not_released(2, 1) .OR. & 938 iwrk_not_released(2, 1) ) CALL ctl_stop('fld_weights: failed to release workspace arrays') 939 ! 939 940 END SUBROUTINE fld_weight 940 941 941 SUBROUTINE fld_interp(num, clvar, kw, kk, dta, nrec) 942 943 SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec ) 942 944 !!--------------------------------------------------------------------- 943 945 !! *** ROUTINE fld_interp *** … … 945 947 !! ** Purpose : apply weights to input gridded data to create data 946 948 !! on model grid 947 !! 948 !! ** Method : 949 !!---------------------------------------------------------------------- 950 INTEGER, INTENT(in) :: num ! stream number 951 CHARACTER(LEN=*), INTENT(in) :: clvar ! variable name 952 INTEGER, INTENT(in) :: kw ! weights number 953 INTEGER, INTENT(in) :: kk ! vertical dimension of kk 954 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,kk) :: dta ! output field on model grid 955 INTEGER, INTENT(in) :: nrec ! record number to read (ie time slice) 949 !!---------------------------------------------------------------------- 950 INTEGER , INTENT(in ) :: num ! stream number 951 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 952 INTEGER , INTENT(in ) :: kw ! weights number 953 INTEGER , INTENT(in ) :: kk ! vertical dimension of kk 954 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid 955 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 956 956 !! 957 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 958 INTEGER :: jk, jn, jm ! loop counters 959 INTEGER :: ni, nj ! lengths 960 INTEGER :: jpimin,jpiwid ! temporary indices 961 INTEGER :: jpjmin,jpjwid ! temporary indices 962 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 963 !!---------------------------------------------------------------------- 964 ! 965 957 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 958 INTEGER :: jk, jn, jm ! loop counters 959 INTEGER :: ni, nj ! lengths 960 INTEGER :: jpimin,jpiwid ! temporary indices 961 INTEGER :: jpjmin,jpjwid ! temporary indices 962 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 963 !!---------------------------------------------------------------------- 964 ! 966 965 !! for weighted interpolation we have weights at four corners of a box surrounding 967 966 !! a model grid point, each weight is multiplied by a grid value (bilinear case) … … 1083 1082 END DO 1084 1083 1085 ! gradient in the ij direction1086 DO jk = 1,41087 DO jn = 1, jpj1088 DO jm = 1,jpi1089 ni = ref_wgts(kw)%data_jpi(jm,jn,jk)1090 nj = ref_wgts(kw)%data_jpj(jm,jn,jk)1091 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( &1084 ! gradient in the ij direction 1085 DO jk = 1,4 1086 DO jn = 1, jpj 1087 DO jm = 1,jpi 1088 ni = ref_wgts(kw)%data_jpi(jm,jn,jk) 1089 nj = ref_wgts(kw)%data_jpj(jm,jn,jk) 1090 dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( & 1092 1091 (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni ,nj+2,:)) - & 1093 1092 (ref_wgts(kw)%fly_dta(ni+2,nj ,:) - ref_wgts(kw)%fly_dta(ni ,nj ,:))) 1093 END DO 1094 1094 END DO 1095 END DO 1096 END DO 1097 1095 END DO 1096 ! 1098 1097 END IF 1099 1098 ! 1100 1099 END SUBROUTINE fld_interp 1101 1100 … … 1106 1105 !! 1107 1106 !! ** Purpose : 1108 !!1109 !! ** Method :1110 1107 !!--------------------------------------------------------------------- 1111 1108 CHARACTER(len=*), INTENT(in) :: cdday !3 first letters of the first day of the weekly file … … 1119 1116 DO ijul = 1, 7 1120 1117 IF( cl_week(ijul) == TRIM(cdday) ) EXIT 1121 END DO1118 END DO 1122 1119 IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%cltype(6:8): '//TRIM(cdday) ) 1123 1120 ! … … 1129 1126 END FUNCTION ksec_week 1130 1127 1131 1128 !!====================================================================== 1132 1129 END MODULE fldread
Note: See TracChangeset
for help on using the changeset viewer.
