| [8586] | 1 | #if defined MULTI |
|---|
| 2 | # define NAT_IN(k) cd_nat(k) |
|---|
| 3 | # define SGN_IN(k) psgn(k) |
|---|
| 4 | # define F_SIZE(ptab) kfld |
|---|
| 5 | # if defined DIM_2d |
|---|
| 6 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) |
|---|
| 7 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) |
|---|
| 8 | # define K_SIZE(ptab) 1 |
|---|
| 9 | # define L_SIZE(ptab) 1 |
|---|
| 10 | # endif |
|---|
| 11 | # if defined DIM_3d |
|---|
| 12 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) |
|---|
| 13 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) |
|---|
| 14 | # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) |
|---|
| 15 | # define L_SIZE(ptab) 1 |
|---|
| 16 | # endif |
|---|
| 17 | # if defined DIM_4d |
|---|
| 18 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) |
|---|
| 19 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) |
|---|
| 20 | # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) |
|---|
| 21 | # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) |
|---|
| 22 | # endif |
|---|
| 23 | #else |
|---|
| 24 | # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) |
|---|
| 25 | # define NAT_IN(k) cd_nat |
|---|
| 26 | # define SGN_IN(k) psgn |
|---|
| 27 | # define F_SIZE(ptab) 1 |
|---|
| 28 | # if defined DIM_2d |
|---|
| 29 | # define ARRAY_IN(i,j,k,l,f) ptab(i,j) |
|---|
| 30 | # define K_SIZE(ptab) 1 |
|---|
| 31 | # define L_SIZE(ptab) 1 |
|---|
| 32 | # endif |
|---|
| 33 | # if defined DIM_3d |
|---|
| 34 | # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) |
|---|
| 35 | # define K_SIZE(ptab) SIZE(ptab,3) |
|---|
| 36 | # define L_SIZE(ptab) 1 |
|---|
| 37 | # endif |
|---|
| 38 | # if defined DIM_4d |
|---|
| 39 | # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) |
|---|
| 40 | # define K_SIZE(ptab) SIZE(ptab,3) |
|---|
| 41 | # define L_SIZE(ptab) SIZE(ptab,4) |
|---|
| 42 | # endif |
|---|
| 43 | #endif |
|---|
| 44 | |
|---|
| 45 | #if defined MULTI |
|---|
| 46 | SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval ) |
|---|
| 47 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
|---|
| 48 | #else |
|---|
| 49 | SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn , cd_mpp, pval ) |
|---|
| 50 | #endif |
|---|
| 51 | ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied |
|---|
| 52 | CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points |
|---|
| 53 | REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary |
|---|
| 54 | CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only |
|---|
| 55 | REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) |
|---|
| 56 | ! |
|---|
| 57 | INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices |
|---|
| 58 | INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array |
|---|
| 59 | REAL(wp) :: zland |
|---|
| 60 | LOGICAL :: ll_Iperio, ll_Jperio, ll_nfd |
|---|
| 61 | !!---------------------------------------------------------------------- |
|---|
| 62 | ! |
|---|
| 63 | ipk = K_SIZE(ptab) ! 3rd dimension |
|---|
| 64 | ipl = L_SIZE(ptab) ! 4th - |
|---|
| 65 | ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) |
|---|
| 66 | ! |
|---|
| 67 | ll_Iperio = nperio==1 .OR. nperio==4 .OR. nperio==6 |
|---|
| 68 | ll_Jperio = jperio==7 |
|---|
| 69 | ll_nfd = nperio==3 .OR. nperio==4 .OR. nperio==5 .OR. nperio==6 |
|---|
| 70 | ! |
|---|
| 71 | IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value |
|---|
| 72 | ELSE ; zland = 0._wp ! zero by default |
|---|
| 73 | ENDIF |
|---|
| 74 | |
|---|
| 75 | ! ------------------------------- ! |
|---|
| 76 | ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible |
|---|
| 77 | ! ------------------------------- ! |
|---|
| 78 | ! |
|---|
| 79 | IF( PRESENT( cd_mpp ) ) THEN !== halos filled with inner values ==! |
|---|
| 80 | ! |
|---|
| 81 | ! only fill the overlap area and extra allows |
|---|
| 82 | ! this is in mpp case. In this module, just do nothing |
|---|
| 83 | ! |
|---|
| 84 | ELSE !== standard close or cyclic treatment ==! |
|---|
| 85 | ! |
|---|
| 86 | DO jf = 1, ipf ! number of arrays to be treated |
|---|
| 87 | ! |
|---|
| 88 | ! ! East-West boundaries |
|---|
| 89 | IF( ll_Iperio ) THEN !* cyclic |
|---|
| 90 | ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) |
|---|
| 91 | ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) |
|---|
| 92 | ELSE !* closed |
|---|
| 93 | IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 ,:,:,:,jf) = zland ! east except F-point |
|---|
| 94 | ARRAY_IN(jpi,:,:,:,jf) = zland ! west |
|---|
| 95 | ENDIF |
|---|
| 96 | ! ! North-South boundaries |
|---|
| 97 | IF( ll_Jperio ) THEN !* cyclic |
|---|
| 98 | ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) |
|---|
| 99 | ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) |
|---|
| 100 | ELSEIF( ll_nfd ) THEN !* north fold |
|---|
| 101 | IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 ,:,:,jf) = zland ! south except F-point |
|---|
| 102 | CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) ) ! north fold treatment |
|---|
| 103 | ELSE !* closed |
|---|
| 104 | IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 ,:,:,jf) = zland ! south except F-point |
|---|
| 105 | ARRAY_IN(:,jpj,:,:,jf) = zland ! north |
|---|
| 106 | ENDIF |
|---|
| 107 | ! |
|---|
| 108 | END DO |
|---|
| 109 | ! |
|---|
| 110 | ENDIF |
|---|
| 111 | ! |
|---|
| 112 | END SUBROUTINE ROUTINE_LNK |
|---|
| 113 | |
|---|
| 114 | #undef ARRAY_TYPE |
|---|
| 115 | #undef NAT_IN |
|---|
| 116 | #undef SGN_IN |
|---|
| 117 | #undef ARRAY_IN |
|---|
| 118 | #undef K_SIZE |
|---|
| 119 | #undef L_SIZE |
|---|
| 120 | #undef F_SIZE |
|---|
