Changeset 3294 for trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
- Timestamp:
- 2012-01-28T17:44:18+01:00 (12 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r2715 r3294 27 27 USE agrif_opa_sponge 28 28 USE lib_mpp 29 USE wrk_nemo 29 30 30 31 IMPLICIT NONE … … 47 48 !! *** ROUTINE Agrif_Tra *** 48 49 !!---------------------------------------------------------------------- 49 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released50 USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_251 50 !! 52 INTEGER :: ji, jj, jk ! dummy loop indices51 INTEGER :: ji, jj, jk, jn ! dummy loop indices 53 52 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 54 53 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 55 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zta, zsa54 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 56 55 !!---------------------------------------------------------------------- 57 56 ! 58 57 IF( Agrif_Root() ) RETURN 59 58 60 zta => wrk_3d_1 ; zsa => wrk_3d_2 61 IF( wrk_in_use(3, 1,2) )THEN 62 CALL ctl_stop('agrif_tra: requested workspace arrays unavailable.') 63 RETURN 64 END IF 59 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa ) 65 60 66 61 Agrif_SpecialValue = 0.e0 67 62 Agrif_UseSpecialValue = .TRUE. 68 zta(:,:,:) = 0.e0 69 zsa(:,:,:) = 0.e0 70 71 CALL Agrif_Bc_variable( zta, tn_id, procname = interptn ) 72 CALL Agrif_Bc_variable( zsa, sn_id, procname = interpsn ) 63 ztsa(:,:,:,:) = 0.e0 64 65 CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 73 66 Agrif_UseSpecialValue = .FALSE. 74 67 … … 87 80 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 88 81 89 ta(nlci,:,:) = alpha1 * zta(nlci,:,:) + alpha2 * zta(nlci-1,:,:) 90 sa(nlci,:,:) = alpha1 * zsa(nlci,:,:) + alpha2 * zsa(nlci-1,:,:) 91 92 DO jk = 1, jpkm1 93 DO jj = 1, jpj 94 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 95 ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 96 sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) 97 ELSE 98 ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 99 sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 100 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 101 ta(nlci-1,jj,jk)=( alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk) & 102 & + alpha7*ta(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 103 sa(nlci-1,jj,jk)=( alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk) & 104 & + alpha7*sa(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 82 DO jn = 1, jpts 83 tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 84 DO jk = 1, jpkm1 85 DO jj = 1, jpj 86 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 87 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 88 ELSE 89 tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 90 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 91 tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn) & 92 & + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 93 ENDIF 105 94 ENDIF 106 END IF107 END DO 108 END 95 END DO 96 END DO 97 ENDDO 109 98 ENDIF 110 99 111 100 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 112 101 113 ta(:,nlcj,:) = alpha1 * zta(:,nlcj,:) + alpha2 * zta(:,nlcj-1,:) 114 sa(:,nlcj,:) = alpha1 * zsa(:,nlcj,:) + alpha2 * zsa(:,nlcj-1,:) 115 116 DO jk = 1, jpkm1 117 DO ji = 1, jpi 118 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 119 ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 120 sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 121 ELSE 122 ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 123 sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 124 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 125 ta(ji,nlcj-1,jk)=( alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk) & 126 & + alpha7*ta(ji,nlcj-3,jk) ) * tmask(ji,nlcj-1,jk) 127 sa(ji,nlcj-1,jk)=( alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk) & 128 & + alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 102 DO jn = 1, jpts 103 tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 104 DO jk = 1, jpkm1 105 DO ji = 1, jpi 106 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 107 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 108 ELSE 109 tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 110 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 111 tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn) & 112 & + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 113 ENDIF 129 114 ENDIF 130 END IF131 END DO 132 END DO115 END DO 116 END DO 117 ENDDO 133 118 ENDIF 134 119 135 120 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 136 ta(1,:,:) = alpha1 * zta(1,:,:) + alpha2 * zta(2,:,:) 137 sa(1,:,:) = alpha1 * zsa(1,:,:) + alpha2 * zsa(2,:,:) 138 DO jk = 1, jpkm1 139 DO jj = 1, jpj 140 IF( umask(2,jj,jk) == 0.e0 ) THEN 141 ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 142 sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) 143 ELSE 144 ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk) 145 sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 146 IF( un(2,jj,jk) < 0.e0 ) THEN 147 ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 148 sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) 121 DO jn = 1, jpts 122 tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 123 DO jk = 1, jpkm1 124 DO jj = 1, jpj 125 IF( umask(2,jj,jk) == 0.e0 ) THEN 126 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 127 ELSE 128 tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 129 IF( un(2,jj,jk) < 0.e0 ) THEN 130 tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 131 ENDIF 149 132 ENDIF 150 END IF133 END DO 151 134 END DO 152 135 END DO … … 154 137 155 138 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 156 ta(:,1,:) = alpha1 * zta(:,1,:) + alpha2 * zta(:,2,:) 157 sa(:,1,:) = alpha1 * zsa(:,1,:) + alpha2 * zsa(:,2,:) 158 DO jk=1,jpk 159 DO ji=1,jpi 160 IF( vmask(ji,2,jk) == 0.e0 ) THEN 161 ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 162 sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) 163 ELSE 164 ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 165 sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk) 166 IF( vn(ji,2,jk) < 0.e0 ) THEN 167 ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 168 sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) 139 DO jn = 1, jpts 140 tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 141 DO jk=1,jpk 142 DO ji=1,jpi 143 IF( vmask(ji,2,jk) == 0.e0 ) THEN 144 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 145 ELSE 146 tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 147 IF( vn(ji,2,jk) < 0.e0 ) THEN 148 tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 149 ENDIF 169 150 ENDIF 170 END IF171 END DO 172 END 151 END DO 152 END DO 153 ENDDO 173 154 ENDIF 174 155 ! 175 IF( wrk_not_released(3, 1,2) ) THEN 176 CALL ctl_stop('agrif_tra: failed to release workspace arrays.') 177 ENDIF 156 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa ) 178 157 ! 179 158 END SUBROUTINE Agrif_tra … … 184 163 !! *** ROUTINE Agrif_DYN *** 185 164 !!---------------------------------------------------------------------- 186 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released187 USE wrk_nemo, ONLY: wrk_2d_4, wrk_2d_5188 USE wrk_nemo, ONLY: wrk_2d_6, wrk_2d_7189 USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2190 165 !! 191 166 INTEGER, INTENT(in) :: kt … … 201 176 IF( Agrif_Root() ) RETURN 202 177 203 spgu1 => wrk_2d_4 ; spgv1 => wrk_2d_5 204 zua2d => wrk_2d_6 ; zva2d => wrk_2d_7 205 zua => wrk_3d_1 ; zva => wrk_3d_2 206 IF( wrk_in_use(2, 4,5,6,7) .OR. wrk_in_use(3, 1,2) )THEN 207 CALL ctl_stop('agrif_dyn: requested workspace arrays unavailable.') 208 RETURN 209 END IF 178 CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 179 CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 210 180 211 181 zrhox = Agrif_Rhox() … … 520 490 ENDIF 521 491 ! 522 IF( wrk_not_released(3, 1,2) .OR. wrk_not_released(2, 4,5,6,7)) THEN 523 CALL ctl_stop('agrif_dyn: failed to release workspace arrays.') 524 ENDIF 492 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 493 CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 525 494 ! 526 495 END SUBROUTINE Agrif_dyn
Note: See TracChangeset
for help on using the changeset viewer.
