Changeset 1605 for trunk/NEMO/NST_SRC/agrif_opa_interp.F90
- Timestamp:
- 2009-08-11T14:33:40+02:00 (15 years ago)
- File:
-
- 1 edited
-
trunk/NEMO/NST_SRC/agrif_opa_interp.F90 (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/NST_SRC/agrif_opa_interp.F90
r1300 r1605 1 1 MODULE agrif_opa_interp 2 !!====================================================================== 3 !! *** MODULE agrif_opa_interp *** 4 !! AGRIF: interpolation package 5 !!====================================================================== 6 !! History : 2.0 ! 2002-06 (XXX) Original cade 7 !! - ! 2005-11 (XXX) 8 !! 3.2 ! 2009-04 (R. Benshila) 9 !!---------------------------------------------------------------------- 2 10 #if defined key_agrif && ! defined key_off_tra 11 !!---------------------------------------------------------------------- 12 !! 'key_agrif' AGRIF zoom 13 !! NOT 'key_off_tra' NO off-line tracers 14 !!---------------------------------------------------------------------- 15 !! Agrif_tra : 16 !! Agrif_dyn : 17 !! interpu : 18 !! interpv : 19 !!---------------------------------------------------------------------- 3 20 USE par_oce 4 21 USE oce … … 6 23 USE sol_oce 7 24 USE agrif_oce 25 USE phycst 26 USE in_out_manager 8 27 9 28 IMPLICIT NONE 10 29 PRIVATE 11 30 12 PUBLIC Agrif_tra, Agrif_dyn, interpu, interpv 13 14 !!---------------------------------------------------------------------- 15 !! OPA 9.0 , LOCEAN-IPSL (2006) 31 PUBLIC Agrif_tra, Agrif_dyn, interpu, interpv 32 33 # include "domzgr_substitute.h90" 34 # include "vectopt_loop_substitute.h90" 35 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009) 16 37 !! $Id$ 17 38 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) … … 21 42 22 43 SUBROUTINE Agrif_tra 23 !!--------------------------------------------- 24 !! *** ROUTINE Agrif_Tra *** 25 !!--------------------------------------------- 26 # include "domzgr_substitute.h90" 27 # include "vectopt_loop_substitute.h90" 28 29 INTEGER :: ji,jj,jk 30 REAL(wp) :: zrhox 31 REAL(wp) :: alpha1, alpha2, alpha3, alpha4 32 REAL(wp) :: alpha5, alpha6, alpha7 33 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zta, zsa 44 !!---------------------------------------------------------------------- 45 !! *** ROUTINE Agrif_Tra *** 46 !!---------------------------------------------------------------------- 47 INTEGER :: ji, jj, jk ! dummy loop indices 48 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 49 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 50 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zta, zsa ! 3D workspace 51 !!---------------------------------------------------------------------- 34 52 ! 35 IF( Agrif_Root())RETURN36 37 Agrif_SpecialValue =0.53 IF( Agrif_Root() ) RETURN 54 55 Agrif_SpecialValue = 0.e0 38 56 Agrif_UseSpecialValue = .TRUE. 39 zta = 0.e040 zsa = 0.e041 42 CALL Agrif_Bc_variable( zta,tn)43 CALL Agrif_Bc_variable( zsa,sn)57 zta(:,:,:) = 0.e0 58 zsa(:,:,:) = 0.e0 59 60 CALL Agrif_Bc_variable( zta, tn ) 61 CALL Agrif_Bc_variable( zsa, sn ) 44 62 Agrif_UseSpecialValue = .FALSE. 45 63 46 64 zrhox = Agrif_Rhox() 47 65 48 alpha1 = ( zrhox-1.)/2.49 alpha2 = 1. -alpha150 51 alpha3 = ( zrhox-1)/(zrhox+1)52 alpha4 = 1. -alpha353 54 alpha6 = 2. *(zrhox-1.)/(zrhox+1.)55 alpha7 = -(zrhox-1)/(zrhox+3)66 alpha1 = ( zrhox - 1. ) * 0.5 67 alpha2 = 1. - alpha1 68 69 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 70 alpha4 = 1. - alpha3 71 72 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 73 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 56 74 alpha5 = 1. - alpha6 - alpha7 57 75 58 IF( (nbondi == 1).OR.(nbondi == 2)) THEN76 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 59 77 60 78 ta(nlci,:,:) = alpha1 * zta(nlci,:,:) + alpha2 * zta(nlci-1,:,:) 61 79 sa(nlci,:,:) = alpha1 * zsa(nlci,:,:) + alpha2 * zsa(nlci-1,:,:) 62 80 63 DO jk =1,jpk64 DO jj =1,jpj65 IF (umask(nlci-2,jj,jk).EQ.0.) THEN81 DO jk = 1, jpkm1 82 DO jj = 1, jpj 83 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 66 84 ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 67 85 sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) … … 69 87 ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 70 88 sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 71 IF (un(nlci-2,jj,jk).GT.0.) THEN89 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 72 90 ta(nlci-1,jj,jk)=( alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk) & 73 91 & + alpha7*ta(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 74 92 sa(nlci-1,jj,jk)=( alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk) & 75 93 & + alpha7*sa(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 76 94 ENDIF 77 95 ENDIF … … 80 98 ENDIF 81 99 82 IF( (nbondj == 1).OR.(nbondj == 2)) THEN100 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 83 101 84 102 ta(:,nlcj,:) = alpha1 * zta(:,nlcj,:) + alpha2 * zta(:,nlcj-1,:) 85 103 sa(:,nlcj,:) = alpha1 * zsa(:,nlcj,:) + alpha2 * zsa(:,nlcj-1,:) 86 104 87 DO jk =1,jpk88 DO ji =1,jpi89 IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN105 DO jk = 1, jpkm1 106 DO ji = 1, jpi 107 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 90 108 ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 91 109 sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) … … 93 111 ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 94 112 sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 95 IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN113 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 96 114 ta(ji,nlcj-1,jk)=( alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk) & 97 115 & + alpha7*ta(ji,nlcj-3,jk) ) * tmask(ji,nlcj-1,jk) 98 116 sa(ji,nlcj-1,jk)=( alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk) & 99 117 & + alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 100 118 ENDIF 101 119 ENDIF … … 104 122 ENDIF 105 123 106 IF( (nbondi == -1).OR.(nbondi == 2)) THEN124 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 107 125 ta(1,:,:) = alpha1 * zta(1,:,:) + alpha2 * zta(2,:,:) 108 126 sa(1,:,:) = alpha1 * zsa(1,:,:) + alpha2 * zsa(2,:,:) 109 DO jk =1,jpk110 DO jj =1,jpj111 IF (umask(2,jj,jk).EQ.0.) THEN127 DO jk = 1, jpkm1 128 DO jj = 1, jpj 129 IF( umask(2,jj,jk) == 0.e0 ) THEN 112 130 ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 113 131 sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) … … 115 133 ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk) 116 134 sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 117 IF (un(2,jj,jk).LT.0.) THEN135 IF( un(2,jj,jk) < 0.e0 ) THEN 118 136 ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 119 137 sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) … … 124 142 ENDIF 125 143 126 IF( (nbondj == -1).OR.(nbondj == 2)) THEN144 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 127 145 ta(:,1,:) = alpha1 * zta(:,1,:) + alpha2 * zta(:,2,:) 128 146 sa(:,1,:) = alpha1 * zsa(:,1,:) + alpha2 * zsa(:,2,:) 129 147 DO jk=1,jpk 130 148 DO ji=1,jpi 131 IF (vmask(ji,2,jk).EQ.0.) THEN149 IF( vmask(ji,2,jk) == 0.e0 ) THEN 132 150 ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 133 151 sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) … … 135 153 ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 136 154 sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk) 137 IF (vn(ji,2,jk) .LT. 0.) THEN155 IF( vn(ji,2,jk) < 0.e0 ) THEN 138 156 ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 139 157 sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) … … 143 161 END DO 144 162 ENDIF 145 163 ! 146 164 END SUBROUTINE Agrif_tra 147 165 166 148 167 SUBROUTINE Agrif_dyn( kt ) 149 !!--------------------------------------------- 150 !! *** ROUTINE Agrif_DYN *** 151 !!--------------------------------------------- 152 USE phycst 153 USE in_out_manager 154 155 # include "domzgr_substitute.h90" 156 157 INTEGER, INTENT(in) :: kt 158 168 !!---------------------------------------------------------------------- 169 !! *** ROUTINE Agrif_DYN *** 170 !!---------------------------------------------------------------------- 171 INTEGER, INTENT(in) :: kt 172 !! 173 INTEGER :: ji,jj,jk 159 174 REAL(wp) :: timeref 160 175 REAL(wp) :: z2dt, znugdt … … 163 178 REAL(wp), DIMENSION(jpi,jpj) :: spgu1,spgv1 164 179 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zua, zva 165 INTEGER :: ji,jj,jk166 167 IF (Agrif_Root())RETURN180 !!---------------------------------------------------------------------- 181 182 IF( Agrif_Root() ) RETURN 168 183 169 184 zrhox = Agrif_Rhox() … … 177 192 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 178 193 ! coefficients 179 znugdt = rnu *grav * z2dt194 znugdt = grav * z2dt 180 195 181 196 Agrif_SpecialValue=0. … … 505 520 END SUBROUTINE Agrif_dyn 506 521 522 507 523 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 508 !!--------------------------------------------- 509 !! *** ROUTINE interpu *** 510 !!--------------------------------------------- 511 # include "domzgr_substitute.h90" 512 524 !!---------------------------------------------------------------------- 525 !! *** ROUTINE interpu *** 526 !!---------------------------------------------------------------------- 513 527 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 514 528 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 515 529 !! 516 530 INTEGER :: ji,jj,jk 531 !!---------------------------------------------------------------------- 517 532 518 533 DO jk=k1,k2 … … 528 543 END SUBROUTINE interpu 529 544 545 530 546 SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 531 !!--------------------------------------------- 532 !! *** ROUTINE interpu2d *** 533 !!--------------------------------------------- 534 547 !!---------------------------------------------------------------------- 548 !! *** ROUTINE interpu2d *** 549 !!---------------------------------------------------------------------- 535 550 INTEGER, INTENT(in) :: i1,i2,j1,j2 536 551 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 537 552 !! 538 553 INTEGER :: ji,jj 554 !!---------------------------------------------------------------------- 539 555 540 556 DO jj=j1,j2 … … 547 563 END SUBROUTINE interpu2d 548 564 565 549 566 SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 550 !!--------------------------------------------- 551 !! *** ROUTINE interpv *** 552 !!--------------------------------------------- 553 # include "domzgr_substitute.h90" 554 567 !!---------------------------------------------------------------------- 568 !! *** ROUTINE interpv *** 569 !!---------------------------------------------------------------------- 555 570 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 556 571 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 557 572 !! 558 573 INTEGER :: ji, jj, jk 574 !!---------------------------------------------------------------------- 559 575 560 576 DO jk=k1,k2 … … 571 587 END SUBROUTINE interpv 572 588 589 573 590 SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 574 !!--------------------------------------------- 575 !! *** ROUTINE interpv2d *** 576 !!--------------------------------------------- 577 591 !!---------------------------------------------------------------------- 592 !! *** ROUTINE interpu2d *** 593 !!---------------------------------------------------------------------- 578 594 INTEGER, INTENT(in) :: i1,i2,j1,j2 579 595 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 580 596 !! 581 597 INTEGER :: ji,jj 598 !!---------------------------------------------------------------------- 582 599 583 600 DO jj=j1,j2 … … 591 608 592 609 #else 610 !!---------------------------------------------------------------------- 611 !! Empty module no AGRIF zoom 612 !!---------------------------------------------------------------------- 593 613 CONTAINS 594 595 614 SUBROUTINE Agrif_OPA_Interp_empty 596 !!---------------------------------------------597 !! *** ROUTINE agrif_OPA_Interp_empty ***598 !!---------------------------------------------599 615 WRITE(*,*) 'agrif_opa_interp : You should not have seen this print! error?' 600 616 END SUBROUTINE Agrif_OPA_Interp_empty 601 617 #endif 618 619 !!====================================================================== 602 620 END MODULE agrif_opa_interp
Note: See TracChangeset
for help on using the changeset viewer.
