Changeset 3294 for trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
- Timestamp:
- 2012-01-28T17:44:18+01:00 (12 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 (modified) (8 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r2802 r3294 9 9 USE in_out_manager ! I/O manager 10 10 USE lib_mpp 11 USE traswp12 11 USE wrk_nemo 12 13 13 IMPLICIT NONE 14 14 PRIVATE … … 30 30 !! *** ROUTINE Agrif_Update_Tra *** 31 31 !!--------------------------------------------- 32 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released33 USE wrk_nemo, ONLY: wrk_3d_134 32 !! 35 33 INTEGER, INTENT(in) :: kt 36 REAL(wp), POINTER, DIMENSION(:,:,: ) :: ztab34 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 37 35 38 36 39 37 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 40 38 #if defined TWO_WAY 41 ztab => wrk_3d_1 42 IF( wrk_in_use(3, 1) ) THEN 43 CALL ctl_stop('agrif_update_tra: ERROR: requested workspace arrays unavailable') 44 RETURN 45 END IF 39 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 46 40 47 41 Agrif_UseSpecialValueInUpdate = .TRUE. … … 49 43 50 44 IF (MOD(nbcline,nbclineupdate) == 0) THEN 51 CALL Agrif_Update_Variable(ztab,tn_id, procname=updateT) 52 CALL Agrif_Update_Variable(ztab,sn_id, procname=updateS) 53 ELSE 54 CALL Agrif_Update_Variable(ztab,tn_id,locupdate=(/0,2/), procname=updateT) 55 CALL Agrif_Update_Variable(ztab,sn_id,locupdate=(/0,2/), procname=updateS) 45 CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 46 ELSE 47 CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 56 48 ENDIF 57 49 58 50 Agrif_UseSpecialValueInUpdate = .FALSE. 59 51 60 CALL Agrif_ChildGrid_To_ParentGrid() 61 CALL tra_swap 62 CALL Agrif_ParentGrid_To_ChildGrid() 63 64 IF( wrk_not_released(3, 1) ) THEN 65 CALL ctl_stop('Agrif_Update_Tra: ERROR: failed to release workspace arrays') 66 END IF 52 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 67 53 #endif 68 54 … … 73 59 !! *** ROUTINE Agrif_Update_Dyn *** 74 60 !!--------------------------------------------- 75 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released76 USE wrk_nemo, ONLY: wrk_2d_177 USE wrk_nemo, ONLY: wrk_3d_178 61 !! 79 62 INTEGER, INTENT(in) :: kt … … 84 67 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 85 68 #if defined TWO_WAY 86 ztab => wrk_3d_1 ; ztab2d => wrk_2d_1 87 IF( ( wrk_in_use(2, 1)) .OR. wrk_in_use(3, 1) )THEN 88 CALL ctl_stop('agrif_update_dyn: ERROR: requested workspace arrays unavailable') 89 RETURN 90 END IF 69 CALL wrk_alloc( jpi, jpj, ztab2d ) 70 CALL wrk_alloc( jpi, jpj, jpk, ztab ) 91 71 92 72 IF (mod(nbcline,nbclineupdate) == 0) THEN … … 108 88 Agrif_UseSpecialValueInUpdate = .FALSE. 109 89 110 IF( wrk_not_released(2, 1) .OR. wrk_not_released(3, 1) )THEN 111 CALL ctl_stop('agrif_update_dyn: ERROR: failed to release workspace arrays') 112 END IF 90 CALL wrk_dealloc( jpi, jpj, ztab2d ) 91 CALL wrk_dealloc( jpi, jpj, jpk, ztab ) 113 92 114 93 !Done in step … … 129 108 END SUBROUTINE recompute_diags 130 109 131 SUBROUTINE updateT ( tabres, i1, i2, j1, j2, k1, k2, before )110 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 132 111 !!--------------------------------------------- 133 112 !! *** ROUTINE updateT *** … … 135 114 # include "domzgr_substitute.h90" 136 115 137 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 138 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres116 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 117 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 139 118 LOGICAL, iNTENT(in) :: before 140 119 141 INTEGER :: ji,jj,jk 142 143 IF (before) THEN 144 DO jk=k1,k2 145 DO jj=j1,j2 146 DO ji=i1,i2 147 tabres(ji,jj,jk) = tn(ji,jj,jk) 148 END DO 149 END DO 150 END DO 151 ELSE 152 DO jk=k1,k2 153 DO jj=j1,j2 154 DO ji=i1,i2 155 IF( tabres(ji,jj,jk) .NE. 0. ) THEN 156 tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 157 ENDIF 158 END DO 159 END DO 160 END DO 161 ENDIF 162 163 END SUBROUTINE updateT 164 165 SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before ) 166 !!--------------------------------------------- 167 !! *** ROUTINE updateS *** 168 !!--------------------------------------------- 169 # include "domzgr_substitute.h90" 170 171 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 172 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 173 LOGICAL, iNTENT(in) :: before 174 175 INTEGER :: ji,jj,jk 176 177 IF (before) THEN 178 DO jk=k1,k2 179 DO jj=j1,j2 180 DO ji=i1,i2 181 tabres(ji,jj,jk) = sn(ji,jj,jk) 182 END DO 183 END DO 184 END DO 185 ELSE 186 DO jk=k1,k2 187 DO jj=j1,j2 188 DO ji=i1,i2 189 IF (tabres(ji,jj,jk).NE.0.) THEN 190 sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 191 ENDIF 192 END DO 193 END DO 194 END DO 195 ENDIF 196 197 END SUBROUTINE updateS 120 INTEGER :: ji,jj,jk,jn 121 122 IF (before) THEN 123 DO jn = n1,n2 124 DO jk=k1,k2 125 DO jj=j1,j2 126 DO ji=i1,i2 127 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 128 END DO 129 END DO 130 END DO 131 END DO 132 ELSE 133 DO jn = n1,n2 134 DO jk=k1,k2 135 DO jj=j1,j2 136 DO ji=i1,i2 137 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 138 tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 139 END IF 140 END DO 141 END DO 142 END DO 143 END DO 144 ENDIF 145 146 END SUBROUTINE updateTS 198 147 199 148 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
Note: See TracChangeset
for help on using the changeset viewer.
