! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE INV_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANSAD* - Inverse spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform - adjoint !** Interface. ! ---------- ! CALL INV_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) ! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) ! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! LDSCDERS - indicating if derivatives of scalar variables are req. ! LDVORGP - indicating if grid-point vorticity is req. ! LDDIVGP - indicating if grid-point divergence is req. ! LDUVDER - indicating if E-W derivatives of u and v are req. ! KPROMA - required blocking factor for gridpoint output ! KVSETUV(:) - indicating which 'b-set' in spectral space owns a ! vor/div field. Equivalant to NBSETLEV in the IFS. ! The length of KVSETUV should be the GLOBAL number ! of u/v fields which is the dimension of u and v releated ! fields in grid-point space. ! KVESETSC(:) - indicating which 'b-set' in spectral space owns a ! scalar field. As for KVSETUV this argument is required ! if the total number of processors is greater than ! the number of processors used for distribution in ! spectral wave space. ! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) ! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) ! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:,:) - gridpoint fields (output) ! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where ! NPROMA is the blocking factor, IF_GP the total number ! of output fields and NGPBLKS the number of NPROMA blocks. ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! ! vorticity : IF_UV_G fields (if psvor present and LDVORGP) ! divergence : IF_UV_G fields (if psvor present and LDDIVGP) ! u : IF_UV_G fields (if psvor present) ! v : IF_UV_G fields (if psvor present) ! scalar fields : IF_SCALARS_G fields (if pspscalar present) ! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar ! present and LDSCDERS) ! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) ! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) ! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar ! present and LDSCDERS) ! ! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length ! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction ! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the ! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral ! 'b-set' split ! As an alternative to using PGP you can also use a combination of the ! following arrays. The reason for introducing these alternative ways ! of calling INV_TRANS is to avoid uneccessary copies where your data ! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. ! The use of any of these precludes the use of PGP and vice versa. ! ! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order ! described for PGP. The second dimension of PGPUV should ! be the same as the "global" first dimension of ! PSPVOR,PSPDIV (in the IFS this is the number of levels) ! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (u,v,vor,div ...) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A if no derivatives, 3 times that with der.) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B if no derivatives, 3 times that with der.) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 if no derivatives, 3 times that with der.) ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- LTDIR_CTLAD - control of Legendre transform ! FTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE SET_RESOL_MOD ,ONLY : SET_RESOL USE INV_TRANS_CTLAD_MOD ,ONLY : INV_TRANS_CTLAD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP2(:,:,:) !ifndef INTERFACE ! Local varaibles INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP,IF_OUT_LT INTEGER(KIND=JPIM) :: IF_SCDERS,IF_UV_PAR INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G2,IF_SC3A_G3,IF_SC3B_G2,IF_SC3B_G3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('INV_TRANSAD',0,ZHOOK_HANDLE) CALL GSTATS(1809,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults LVORGP = .FALSE. LDIVGP = .FALSE. LUVDER = .FALSE. IF_UV = 0 IF_UV_G = 0 IF_UV_PAR = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 IF_SCDERS = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G2 = 0 IF_SC3B_G2 = 0 IF_SC3A_G3 = 0 IF_SC3B_G3 = 0 NPROMA = D%NGPTOT LSCDERS = .FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) IF_UV_PAR = 2 DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'INV_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('INV_TRANSAD:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETUV(J) == MYSETV) THEN IF_UV = IF_UV+1 ENDIF ENDDO ELSEIF(PRESENT(PSPVOR)) THEN IF_UV = UBOUND(PSPVOR,1) IF_UV_G = IF_UV IF_UV_PAR = 2 ENDIF IF(PRESENT(KVSETSC)) THEN IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN WRITE(NERR,*) 'INV_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('INV_TRANSAD:KVSETSC TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETSC(J) == MYSETV) THEN IF_SCALARS = IF_SCALARS+1 ENDIF ENDDO ELSEIF(PRESENT(PSPSCALAR)) THEN IF_SCALARS = UBOUND(PSPSCALAR,1) IF_SCALARS_G = IF_SCALARS ENDIF IF(PRESENT(KVSETSC2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANSAD:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+UBOUND(KVSETSC2,1) DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'INV_TRANSAD:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('INV_TRANSAD:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETSC2(J) == MYSETV) THEN IF_SCALARS = IF_SCALARS+1 NF_SC2 = NF_SC2+1 ENDIF ENDDO ELSEIF(PRESENT(PSPSC2)) THEN IF_SC2_G = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+UBOUND(PSPSC2,1) IF_SCALARS_G = IF_SCALARS_G +UBOUND(PSPSC2,1) NF_SC2 = UBOUND(PSPSC2,1) ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G2 = UBOUND(KVSETSC3A,1) IF_SC3A_G3 = UBOUND(PSPSC3A,3) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G2*IF_SC3A_G3 DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'INV_TRANSAD:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS& &('INV_TRANSAD:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETSC3A(J) == MYSETV) THEN IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) NF_SC3A = NF_SC3A+1 ENDIF ENDDO ELSEIF(PRESENT(PSPSC3A)) THEN IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) IF_SC3A_G2 = UBOUND(PSPSC3A,1) IF_SC3A_G3 = UBOUND(PSPSC3A,3) IF_SCALARS_G = IF_SCALARS_G + IF_SC3A_G2*IF_SC3A_G3 NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G2 = UBOUND(KVSETSC3B,1) IF_SC3B_G3 = UBOUND(PSPSC3B,3) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G2*IF_SC3B_G3 DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'INV_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETSC3B(J) == MYSETV) THEN IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) NF_SC3B = NF_SC3B+1 ENDIF ENDDO ELSEIF(PRESENT(PSPSC3B)) THEN IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) IF_SC3B_G2 = UBOUND(PSPSC3B,1) IF_SC3B_G3 = UBOUND(PSPSC3B,3) IF_SCALARS_G = IF_SCALARS_G + IF_SC3B_G2*IF_SC3B_G3 NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(LDSCDERS)) THEN LSCDERS = LDSCDERS IF (LSCDERS) IF_SCDERS = IF_SCALARS ENDIF ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF IF(PRESENT(LDVORGP)) THEN LVORGP = LDVORGP ENDIF IF(PRESENT(LDDIVGP)) THEN LDIVGP = LDDIVGP ENDIF IF(PRESENT(LDUVDER)) THEN LUVDER = LDUVDER ENDIF ! Compute derived variables IF(LVORGP) LDIVGP = .TRUE. NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS IF(IF_UV > 0 .AND. LVORGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF(IF_UV > 0 .AND. LDIVGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF_FS = IF_OUT_LT+IF_SCDERS IF(IF_UV > 0 .AND. LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN IF_GP = IF_GP+2*IF_SCALARS_G IF_SC2_G = IF_SC2_G*3 IF_SC3A_G3 = IF_SC3A_G3*3 IF_SC3B_G3 = IF_SC3B_G3*3 ENDIF IF(IF_UV_G > 0 .AND. LVORGP) THEN IF_GP = IF_GP+IF_UV_G IF_UV_PAR = IF_UV_PAR+1 ENDIF IF(IF_UV_G > 0 .AND. LDIVGP) THEN IF_GP = IF_GP+IF_UV_G IF_UV_PAR = IF_UV_PAR+1 ENDIF IF(IF_UV_G > 0 .AND. LUVDER) THEN IF_GP = IF_GP+2*IF_UV_G IF_UV_PAR = IF_UV_PAR+2 ENDIF ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS("INV_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING") ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS("INV_TRANSAD : PSPVOR TOO SHORT") ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS("INV_TRANSAD : IF_UV > 0 BUT PSPDIV MISSING") ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& & UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS("INV_TRANSAD : PSPDIV TOO SHORT") ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('INV_TRANS : PSPSCALAR TOO SHORT') ENDIF ELSEIF(PRESENT(PSPSC3A)) THEN ENDIF ENDIF IF(IF_UV_G == 0) THEN LUVDER = .FALSE. ENDIF IF(NPRTRV >1) THEN IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& &NPRTRV,IF_UV CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& &NPRTRV CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& &NPRTRV CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& &NPRTRV CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& &NPRTRV CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP WRITE(NOUT,*)'IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER ',& & IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER CALL ABORT_TRANS('INV_TRANSAD:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ELSE IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN CALL ABORT_TRANS('INV_TRANSAD:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('INV_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANSAD:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') ENDIF ENDIF IF(IF_SC2_G > 0) THEN IF(PRESENT(PGP2)) THEN IUBOUND(1:3)=UBOUND(PGP2) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANSAD:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANSAD:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G3 > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANSAD:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANSAD:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G3 > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANSAD:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1809,1) ! ------------------------------------------------------------------ ! Perform transform CALL INV_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_OUT_LT,& & IF_UV,IF_SCALARS,IF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('INV_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE INV_TRANSAD