!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE TESTSP(KULOUT) 1,71
#if defined (DOC)
*
***s/r TESTSP - Test of the exactness of the spectral transform
*
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
* . L. Fillion *RPN/AES Feb 93 - Test of BILIN and BILINAD
* . P. Gauthier *ARMA/AES May 25,1993: - Treatment of specific humidity
* . and surface pressure
* . - Analytical test for a single wave
* removed.
* . L. Fillion *RPN/AES Aug 93
* . - Test of sef-adjointness of LINBAL
* . L. Fillion *ARMA/AES Sep 94
* . - Test of the adjoint of the transformed operator
* . - Test of the adjoint of the inverse transformed
* operator
* . S. Pellerin *ARMA/AES Sept 97.
* - Change from TT to GZ state variables.
* . S. Pellerin *ARMA/SMC May 2000
* - Fix for F90 conversion
* -------------------
** Purpose: verification of the spectral transform
* .
*
*Arguments
* KULOUT: logical unit for printing
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comlun.cdk"
#include "com2ini.cdk"
#include "comsp.cdk"
#include "comsp1.cdk"
*
C
INTEGER KULOUT
C
LOGICAL LLFPLAN
INTEGER ILEN, IERR, JI, JLEV, JK
REAL*8 ZTRANS(NLA,2,NFLEV), ZX(NLA,2,NKSDIM)
POINTER (PXTRANS,ZTRANS), (PXX,ZX)
C
ILEN = NLA*2*NFLEV
CALL HPALLOC(PXTRANS,MAX(ILEN,1),IERR,8)
ILEN = NLA*2*NKSDIM
CALL HPALLOC(PXX,MAX(ILEN,1),IERR,8)
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(//,' -Testing the spectral transforms and their adjoints')
C
SINVOR = 1.
SINDIV = 1.
SINGZ = 1.
SINQ = 1.
SINPS = 1.
GINUU = 1.
GINGZ = 1.
GINQ = 1.
GINPS = 1.
C
C
C* 1. Spectral transform * Inverse spectral transform
C . -----------------------------------------------
100 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No. 1: GDSP * SPGD'')')
CALL INITRND('S',KULOUT)
CALL SPGD
CALL TRANSFER('GD01')
CALL DOTEUCL('G',KULOUT)
CALL GDSP
CALL SPGD
CALL DOTEUCL('G',KULOUT)
C
C* 2. Inverse spectral transform * Spectral transform
C . -----------------------------------------------
200 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.2 : SPGD * GDSP'')')
WRITE(KULOUT,FMT='(8X,''Results for GZ should be the '',
S ''same as in Test No.1'')')
C
CALL TRANSFER('SP01')
CALL DOTEUCL('S',KULOUT)
CALL SPGD
CALL GDSP
CALL DOTEUCL('S',KULOUT)
C
C* 3. Adjoint of the spectral transform
C . ---------------------------------
300 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.3: Adjoint of GDSP'')')
C
CALL INITRND('S',KULOUT)
CALL SPGD
CALL TRANSFER('GD01')
CALL GDSP
CALL TRANSFER('SP01')
CALL INITRND('S',KULOUT)
CALL DOTEUCL('S',KULOUT)
CALL GDSPA
CALL DOTEUCL('G',KULOUT)
C
C* 4. Adjoint of the inverse spectral transform
C . -----------------------------------------
400 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.4: Adjoint of SPGD'')')
C
CALL INITRND('S',KULOUT)
CALL SPGD
CALL TRANSFER('GD01')
CALL INITRND('S',KULOUT)
CALL TRANSFER('SP01')
C
CALL SPGD
CALL DOTEUCL('G',KULOUT)
CALL TRANSFER('GD10')
CALL SPGDA
CALL DOTEUCL('S',KULOUT)
C
C* 6. Test of BILIN and BILINAD
C . -------------------------
600 CONTINUE
C
WRITE(NULOUT,FMT='(//,4X,"TEST. NO.6: BILIN: BILINAD")')
C
IF(NJSUR.GE.2.AND.NISUR.GE.2)THEN
GINUU = 10.
GINGZ = 10.
GINQ = 1.
GINPS = 1.
C
CALL INITRND('G',KULOUT)
CALL TRANSFER('GD01')
CALL BILIN
CALL TRANSFER('OB01')
CALL INITRND('M',KULOUT)
CALL DOTEUCL('M',KULOUT)
CALL TRANSFER('ZGD0')
CALL BILINAD
CALL DOTEUCL('G',KULOUT)
ELSE
WRITE(NULOUT,FMT=9600)
END IF
9600 FORMAT(4X,"NOT DONE. OVERDIMENSIONING IS LACKING")
C
C* 7. Adjoint of the linear balance operator
C . --------------------------------------
700 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.7: Adjoint of LINBAL'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
WRITE(KULOUT,FMT='(/,8X,''Incremental configuration'')')
WRITE(KULOUT,FMT='(/,8X,''Adjoint check for NVMOD modes'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
C
LLFPLAN = .FALSE.
IF(LLFPLAN) THEN
WRITE(KULOUT,FMT='(/,8X,''F-PLANE TEST'')')
ELSE
WRITE(KULOUT,FMT='(/,8X,''VARIABLE CORIOLIS PARAMETER TEST'')')
ENDIF
CALL INITRND('S',KULOUT)
C
C ENSURE ZERO (0,0) SPECTRAL COMPONENT FOR INCREMENT ON VORTICITY
C
DO 710 JLEV = 1, NFLEV
SPVOR(1,1,JLEV) = 0.0
SPVOR(1,2,JLEV) = 0.0
710 CONTINUE
C
CALL TRANSFER('SP01')
DO 730 JLEV = 1, NFLEV
DO 720 JI = 1, NLA
ZTRANS(JI,1,JLEV) = SPVOR(JI,1,JLEV)
ZTRANS(JI,2,JLEV) = SPVOR(JI,2,JLEV)
720 CONTINUE
730 CONTINUE
CALL LINBAL(+1,LLFPLAN)
CALL TRANSFER('SP01')
CALL INITRND('S',KULOUT)
C
C ENSURE ZERO (0,0) SPECTRAL COMPONENT FOR INCREMENT ON TEMPERATURE
C
DO 740 JLEV = 1, NFLEV
SPGZ(1,1,JLEV) = 0.0
SPGZ(1,2,JLEV) = 0.0
740 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''FIRST PRODUCT, RESULT IN GZ'')')
CALL DOTEUCL('S',KULOUT)
C
CALL TRANSFER('SP01')
CALL LINBAL(-1,LLFPLAN)
DO 760 JLEV = 1, NFLEV
DO 750 JI = 1, NLA
SPVOR1(JI,1,JLEV) = ZTRANS(JI,1,JLEV)
SPVOR1(JI,2,JLEV) = ZTRANS(JI,2,JLEV)
750 CONTINUE
760 CONTINUE
WRITE(KULOUT,FMT='(/,8X,''SECOND PRODUCT, RESULT IN VORT'')')
CALL DOTEUCL('S',KULOUT)
C
CALL HPDEALLC(PXTRANS,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'TESTSP Problem with ZTRANS.')
END IF
C
C* 8. Adjoint of the transformed operator
C . -----------------------------------
800 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.8: Adjoint of PROJ'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
WRITE(KULOUT,FMT='(/,8X,''Adjoint check for NVMOD modes'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
C
CALL INITRND('S',KULOUT)
C
C ENSURE ZERO (0,0) SPECTRAL COMPONENT FOR INCREMENT ON VORTICITY
C
DO 805 JLEV = 1, NFLEV
SPVOR(1,1,JLEV) = 0.0
SPVOR(1,2,JLEV) = 0.0
805 CONTINUE
DO 820 JK = 1, NKSDIM
DO 810 JI = 1, NLA
ZX(JI,1,JK) = SP(JI,1,JK)
ZX(JI,2,JK) = SP(JI,2,JK)
810 CONTINUE
820 CONTINUE
CALL PROJ(.TRUE.)
CALL TRANSFER('SP01')
CALL INITRND('S',KULOUT)
C
C ENSURE ZERO (0,0) SPECTRAL COMPONENT FOR INCREMENT ON TEMPERATURE
C
DO 825 JLEV = 1, NFLEV
SPGZ(1,1,JLEV) = 0.0
SPGZ(1,2,JLEV) = 0.0
825 CONTINUE
CALL DOTEUCL('S',KULOUT)
C
CALL PROJA(.TRUE.)
DO 840 JK = 1, NKSDIM
DO 830 JI = 1, NLA
SPVOR1(JI,1,JK) = ZX(JI,1,JK)
SPVOR1(JI,2,JK) = ZX(JI,2,JK)
830 CONTINUE
840 CONTINUE
CALL DOTEUCL('S',KULOUT)
C
C* 9. Adjoint of the inverse transformed operator
C . -------------------------------------------
900 CONTINUE
C
WRITE(KULOUT,FMT='(/,8X,''Test No.9: Adjoint of PROJI'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
WRITE(KULOUT,FMT='(/,8X,''Adjoint check for NVMOD modes'')')
WRITE(KULOUT,FMT='(/,8X,''*****************************'')')
C
C TEST OF THE INVERSE OF PROJ
C
CALL INITRND('S',KULOUT)
C
C ENSURE ZERO (0,0) SPECTRAL COMPONENT FOR INCREMENT ON VORTICITY
C
DO 905 JLEV = 1, NFLEV
SPVOR(1,1,JLEV) = 0.0
SPVOR(1,2,JLEV) = 0.0
905 CONTINUE
DO 920 JK = 1, NKSDIM
DO 910 JI = 1, NLA
ZX(JI,1,JK) = SP(JI,1,JK)
ZX(JI,2,JK) = SP(JI,2,JK)
910 CONTINUE
920 CONTINUE
CALL TRANSFER('SP01')
DO 940 JK = 1, NKSDIM
DO 930 JI = 1, NLA
SP(JI,1,JK) = ZX(JI,1,JK)
SP(JI,2,JK) = ZX(JI,2,JK)
930 CONTINUE
940 CONTINUE
WRITE(KULOUT,FMT='(/,8X,''<X,X>'')')
CALL DOTEUCL('S',KULOUT)
C
CALL PROJ(.TRUE.)
CALL PROJI(.TRUE.)
CALL TRANSFER('SP01')
DO 960 JK = 1, NKSDIM
DO 950 JI = 1, NLA
SP(JI,1,JK) = ZX(JI,1,JK)
SP(JI,2,JK) = ZX(JI,2,JK)
950 CONTINUE
960 CONTINUE
WRITE(KULOUT,FMT='(/,8X,''<X,P-1PX>'')')
CALL DOTEUCL('S',KULOUT)
C
C TEST OF THE AJOINT OF THE INVERSE PROJECTION
C
CALL PROJI(.TRUE.)
CALL TRANSFER('SP01')
DO 970 JK = 1, NKSDIM
DO 965 JI = 1, NLA
SP(JI,1,JK) = ZX(JI,1,JK)
SP(JI,2,JK) = ZX(JI,2,JK)
965 CONTINUE
970 CONTINUE
WRITE(KULOUT,FMT='(/,8X,''<X,P-1X>'')')
CALL DOTEUCL('S',KULOUT)
C
CALL PROJIA(.TRUE.)
CALL TRANSFER('SP01')
DO 980 JK = 1, NKSDIM
DO 975 JI = 1, NLA
SP(JI,1,JK) = ZX(JI,1,JK)
SP(JI,2,JK) = ZX(JI,2,JK)
975 CONTINUE
980 CONTINUE
WRITE(KULOUT,FMT='(/,8X,''<P-1TX,X>'')')
CALL DOTEUCL('S',KULOUT)
C
CALL HPDEALLC(PXX,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'TESTSP Problem with ZX.')
END IF
C
C
RETURN
END