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