source: flex_extract.git/documentation/FORD/V5/Doc_original/tipuesearch/tipuesearch_content.js @ ee06999

var tipuesearch = {"pages":[{"text":"Flex_extract: Calculation of etadot Developer Info Leopold Haimberger Univ. of Vienna, Dept. of Meteorology & Geophysics","tags":"","loc":"index.html","title":" Flex_extract: Calculation of etadot "},{"text":"Files Dependent On This One sourcefile~~phgrreal.f~~AfferentGraph sourcefile~phgrreal.f phgrreal.f sourcefile~grphreal.f grphreal.f sourcefile~phgrreal.f->sourcefile~grphreal.f sourcefile~preconvert.f90 preconvert.f90 sourcefile~phgrreal.f->sourcefile~preconvert.f90 sourcefile~grphreal.f->sourcefile~preconvert.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which depends upon it. A file \n    is dependent upon another if the latter must be compiled before the former\n    can be. Modules PHTOGR Source Code phgrreal.f Source Code MODULE PHTOGR INTEGER , PARAMETER :: MAXAUF = 36000 CONTAINS SUBROUTINE PHGR213 ( CXMN , FELD , WSAVE , IFAX , Z , MLAT , MNAUF , * MAXL , MAXB , MLEVEL ) C     DIE ROUTINE F]HRT EINE TRANSFORMATION EINER C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN C     RAUM AUF DAS REDUZIERTE GAUSS'SCHE GITTER DURCH C C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN C\tWSAVE  = Working Array fuer Fouriertransformation C     Z \t = LEGENDREFUNKTIONSWERTE C C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN C IMPLICIT NONE C\t\t\tAnzahl der Gitterpunkte auf jedem Breitenkreis INTEGER MLAT ( MAXB / 2 ) INTEGER K , MAXL , MAXB , MLEVEL , MNAUF INTEGER IND ( MAXB ) C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , MAXB / 2 ) REAL CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MLEVEL ) REAL WSAVE ( 8 * MAXB + 15 , MAXB / 2 ) INTEGER :: IFAX ( 10 , MAXB ) IND ( 1 ) = 0 DO 7 K = 2 , MAXB / 2 IND ( K ) = IND ( K - 1 ) + MLAT ( K - 1 ) 7 \t\tC O NTINUE !$OMP PARALLEL DO SCHEDULE(DYNAMIC) DO 17 K = 1 , MAXB / 2 CALL PHSYM ( K , IND , CXMN , FELD , Z , WSAVE , IFAX , MLAT , * MNAUF , MAXL , MAXB , MLEVEL ) 17 C ONTINUE !$OMP END PARALLEL DO RETURN END SUBROUTINE PHGR213 C C SUBROUTINE PHSYM ( K , IND , CXMN , FELD , Z , WSAVE , IFAX , MLAT , * MNAUF , MAXL , MAXB , MLEVEL ) IMPLICIT NONE INTEGER MLAT ( MAXB / 2 ) INTEGER K , L , I , J , LLS , LLPS , LL , LLP , MAXL , MAXB , MLEVEL , MNAUF INTEGER IND ( MAXB ) INTEGER :: IFAX ( 10 , MAXB ) C    FELD DER FOURIERKOEFFIZIENTEN REAL :: CXMS ( 0 : MAXAUF - 1 ), CXMA ( 0 : MAXAUF - 1 ) C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , MAXB / 2 ) REAL ACR , ACI , SCR , SCI REAL CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MLEVEL ) REAL WSAVE ( 8 * MAXB + 15 , MAXB / 2 ) DO 6 L = 1 , MLEVEL LL = 0 LLP = 0 DO 1 I = 0 , MNAUF SCR = 0.D0 SCI = 0.D0 ACR = 0.D0 ACI = 0.D0 LLS = LL LLPS = LLP IF ( 2 * I + 1. LT . MLAT ( K )) THEN C\tInnerste Schleife aufgespalten um if-Abfrage zu sparen DO 18 J = I , MNAUF , 2 SCR = SCR + Z ( LLP , K ) * CXMN ( 2 * LL , L ) SCI = SCI + Z ( LLP , K ) * CXMN ( 2 * LL + 1 , L ) LL = LL + 2 LLP = LLP + 2 18 CONTINUE LL = LLS + 1 LLP = LLPS + 1 DO 19 J = I + 1 , MNAUF , 2 ACR = ACR + Z ( LLP , K ) * CXMN ( 2 * LL , L ) ACI = ACI + Z ( LLP , K ) * CXMN ( 2 * LL + 1 , L ) LL = LL + 2 LLP = LLP + 2 19 CONTINUE ENDIF LL = LLS + ( MNAUF - I + 1 ) LLP = LLPS + ( MNAUF - I + 3 ) CXMS ( 2 * I ) = SCR + ACR CXMS ( 2 * I + 1 ) = SCI + ACI CXMA ( 2 * I ) = SCR - ACR CXMA ( 2 * I + 1 ) = SCI - ACI 1 CONTINUE C         CALL FOURTR(CXMS,FELD(IND(k)+1,L),WSAVE(:,K),MNAUF, C     *MLAT(K),1) C         CALL FOURTR(CXMA,FELD(MAXL-IND(k)-MLAT(K)+1,L), C     *WSAVE(:,K),MNAUF,MLAT(K),1) CALL RFOURTR ( CXMS , WSAVE (:, K ), IFAX (:, K ), MNAUF , * MLAT ( K ), 1 ) FELD ( IND ( k ) + 1 : IND ( K ) + MLAT ( K ), L ) = CXMS ( 0 : MLAT ( K ) - 1 ) CALL RFOURTR ( CXMA , * WSAVE (:, K ), IFAX (:, K ), MNAUF , MLAT ( K ), 1 ) FELD ( MAXL - IND ( k ) - MLAT ( K ) + 1 : MAXL - IND ( k ), L ) = CXMA ( 0 : MLAT ( K ) - 1 ) C         WRITE(*,*) IND+1,FELD(IND+1,L) 6 C ONTINUE END SUBROUTINE PHSYM SUBROUTINE PHGCUT ( CXMN , FELD , WSAVE , IFAX , Z , * MNAUF , MMAX , MAUF , MANF , MAXL , MAXB , MLEVEL ) C     DIE ROUTINE FUEHRT EINE TRANSFORMATION EINER C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN C     RAUM AUF KUGELKOORDINATEN DURCH. Es kann ein Teilausschnitt C\t\t\tDer Erde angegeben werden. Diese Routine ist langsamer als C\t\t\tphgrph C C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN C     BREITE = SINUS DER GEOGRAFISCHEN BREITEN C C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN C     MAUF     ANZAHL DER LAENGEN UND DER FOURIERKOEFFIZIENTEN C     MANF     ANFANG DES LAENGENBEREICHS FUER DAS GITTER, C              AUF DAS INTERPOLIERT WERDEN SOLL C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN C IMPLICIT REAL ( A - H , O - Z ) C    FELD DER FOURIERKOEFFIZIENTEN C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL Z ( 0 :(( MMAX + 3 ) * ( MMAX + 4 )) / 2 , MAXB ) DIMENSION CXMN ( 0 :( MMAX + 1 ) * ( MMAX + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MAXB , MLEVEL ) DIMENSION WSAVE ( 4 * MAUF + 15 ) INTEGER :: IFAX ( 10 ) LOGICAL SYM C C      write(*,*)mauf,mnauf,manf,maxl IF ( MAUF . LE . MNAUF ) WRITE ( * , * ) 'TOO COARSE LONGITUDE RESOLUTION' IF (( MANF . LT . 1 ). OR .( MAXL . LT . 1 ). OR . * ( MANF . GT . MAUF ). OR .( MAXL . GT . MAUF )) THEN WRITE ( * , * ) 'WRONG LONGITUDE RANGE' , MANF , MAXL STOP ENDIF C Pruefe, ob Ausgabegitter symmetrisch zum Aequator ist C Wenn ja soll Symmetrie der Legendrepolynome ausgenutzt werden IF ( MAXB . GT . 4 ) THEN SYM = . TRUE . D O 11 J = 5 , 5 IF ( ABS ( ABS ( Z ( 100 , J )) - ABS ( Z ( 100 , MAXB + 1 - J ))). GT . 1 E - 11 ) * SYM = . FALSE . C\t      WRITE(*,*) ABS(Z(100,J)),ABS(Z(100,MAXB+1-J)) 11 C ONTINUE WRITE ( * , * ) 'Symmetrisch: ' , SYM ELSE SYM = . FALSE . ENDIF IF( S YM ) THEN !$OMP PARALLEL DO DO J = 1 ,( MAXB + 1 ) / 2 CALL PHSYMCUT ( J , CXMN , FELD , Z , WSAVE , IFAX , * MAUF , MNAUF , MAXL , MAXB , MLEVEL , MANF ) ENDDO !$OMP END PARALLEL DO ELS E !$OMP PARALLEL DO DO J = 1 , MAXB CALL PHGPNS ( CXMN , FELD , Z , WSAVE , IFAX , * J , MNAUF , MAUF , MANF , MAXL , MAXB , MLEVEL ) ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE PHGCUT SUBROUTINE PHSYMCUT ( J , CXMN , FELD , Z , WSAVE , IFAX , * MAUF , MNAUF , MAXL , MAXB , MLEVEL , MANF ) IMPLICIT REAL ( A - H , O - Z ) C    FELD DER FOURIERKOEFFIZIENTEN REAL :: CXM ( 0 : MAXAUF - 1 ), CXMA ( 0 : MAXAUF - 1 ) C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , MAXB ) REAL SCR , SCI , ACR , ACI DIMENSION CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MAXB , MLEVEL ) DIMENSION WSAVE ( 4 * MAUF + 15 ) INTEGER :: IFAX ( 10 ) DO 16 L = 1 , MLEVEL LL = 0 LLP = 0 DO 17 I = 0 , MNAUF SCR = 0.D0 SCI = 0.D0 ACR = 0.D0 ACI = 0.D0 LLS = LL LLPS = LLP C\tInnerste Schleife aufgespalten um if-Abfrage zu sparen DO 18 K = I , MNAUF , 2 SCR = SCR + Z ( LLP , J ) * CXMN ( 2 * LL , L ) SCI = SCI + Z ( LLP , J ) * CXMN ( 2 * LL + 1 , L ) LL = LL + 2 LLP = LLP + 2 18 CONTINUE LL = LLS + 1 LLP = LLPS + 1 DO 19 K = I + 1 , MNAUF , 2 ACR = ACR + Z ( LLP , J ) * CXMN ( 2 * LL , L ) ACI = ACI + Z ( LLP , J ) * CXMN ( 2 * LL + 1 , L ) LL = LL + 2 LLP = LLP + 2 19 CONTINUE LL = LLS + MNAUF - I + 1 LLP = LLPS + MNAUF - I + 3 CXM ( 2 * I ) = SCR + ACR CXM ( 2 * I + 1 ) = SCI + ACI CXMA ( 2 * I ) = SCR - ACR CXMA ( 2 * I + 1 ) = SCI - ACI 17 CONTINUE CALL RFOURTR ( CXM , WSAVE , IFAX , MNAUF , MAUF , 1 ) DO 26 I = 0 , MAXL - 1 IF ( MANF + I . LE . MAUF ) THEN FELD ( I + 1 , J , L ) = CXM ( MANF + I - 1 ) ELSE FELD ( I + 1 , J , L ) = CXM ( MANF - MAUF + I - 1 ) ENDIF 26 CONTINUE CALL RFOURTR ( CXMA , WSAVE , IFAX , MNAUF , MAUF , 1 ) DO 36 I = 0 , MAXL - 1 IF ( MANF + I . LE . MAUF ) THEN FELD ( I + 1 , MAXB + 1 - J , L ) = CXMA ( MANF + I - 1 ) ELSE FELD ( I + 1 , MAXB + 1 - J , L ) = CXMA ( MANF - MAUF + I - 1 ) ENDIF 36 CONTINUE 16 CONTINUE END SUBROUTINE PHSYMCUT SUBROUTINE PHGPNS ( CXMN , FELD , Z , WSAVE , IFAX , * J , MNAUF , MAUF , MANF , MAXL , MAXB , MLEVEL ) IMPLICIT NONE INTEGER , intent ( in ) :: MNAUF , MAUF , MANF , J , MAXL , MAXB , MLEVEL REAL :: CXM ( 0 : MAXAUF - 1 ) REAL , intent ( in ) :: Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , MAXB ) REAL , intent ( in ) :: CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL , intent ( in ) :: WSAVE ( 4 * MAUF + 15 ) REAL :: FELD ( MAXL , MAXB , MLEVEL ) INTEGER :: IFAX ( 10 ) INTEGER I , L DO L = 1 , MLEVEL CALL LEGTR ( CXMN (:, L ), CXM , Z (:, J ), MNAUF , MAUF ) CALL RFOURTR ( CXM , WSAVE , IFAX , MNAUF , MAUF , 1 ) DO I = 0 , MAXL - 1 IF ( MANF + I . LE . MAUF ) THEN FELD ( I + 1 , J , L ) = CXM ( MANF + I - 1 ) ELSE FELD ( I + 1 , J , L ) = CXM ( MANF - MAUF + I - 1 ) ENDIF ENDDO ENDDO END SUBROUTINE PHGPNS C SUBROUTINE LEGTR ( CXMN , CXM , Z , MNAUF , MAUF ) IMPLICIT NONE INTEGER MNAUF , MAUF , LL , LLP , I , J REAL CXM ( 0 : MAXAUF - 1 ) REAL CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 ) REAL Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 ) REAL CI , CR C C     DIESE ROUTINE BERECHNET DIE FOURIERKOEFFIZIENTEN CXM C LL = 0 LLP = 0 DO 1 I = 0 , MNAUF CR = 0.D0 CI = 0.D0 DO 2 J = I , MNAUF CR = CR + Z ( LLP ) * CXMN ( 2 * LL ) CI = CI + Z ( LLP ) * CXMN ( 2 * LL + 1 ) LL = LL + 1 LLP = LLP + 1 2 CONTINUE LLP = LLP + 2 CXM ( 2 * I ) = CR CXM ( 2 * I + 1 ) = CI 1 CONTINUE RETURN END SUBROUTINE LEGTR C C C SUBROUTINE RFOURTR ( CXM , TRIGS , IFAX , MNAUF , MAXL , ISIGN ) C     BERECHNET DIE FOURIERSUMME MIT EINEM FFT-ALGORITHMUS IMPLICIT REAL ( A - H , O - Z ) DIMENSION CXM ( 0 : MAXAUF - 1 ) REAL :: WSAVE ( 2 * MAXL ), TRIGS ( 2 * MAXL ) INTEGER IFAX ( 10 ) DO I = MNAUF + 1 , MAXL - 1 CXM ( 2 * I ) = 0.0 CXM ( 2 * I + 1 ) = 0.0 ENDDO CALL FFT99 ( CXM , WSAVE , TRIGS , IFAX , 1 , 1 , MAXL , 1 , 1 ) DO I = 0 , MAXL - 1 CXM ( I ) = CXM ( I + 1 ) ENDDO RETURN END SUBROUTINE RFOURTR C C SUBROUTINE GAULEG ( X1 , X2 , X , W , N ) C     BERECHNET DIE GAUSS+SCHEN BREITEN IMPLICIT REAL ( A - H , O - Z ) DIMENSION X ( N ), W ( N ) PARAMETER ( EPS = 3.D-14 ) M = ( N + 1 ) / 2 XM = 0.5D0 * ( X2 + X1 ) XL = 0.5D0 * ( X2 - X1 ) DO 12 I = 1 , M Z = DCOS ( 3.141592654D0 * ( I - . 25 D0 ) / ( N + . 5 D0 )) 1 CONTINUE P1 = 1.D0 P2 = 0.D0 DO 11 J = 1 , N P3 = P2 P2 = P1 P1 = (( 2.D0 * J - 1.D0 ) * Z * P2 - ( J - 1.D0 ) * P3 ) / J 11 CONTINUE PP = N * ( Z * P1 - P2 ) / ( Z * Z - 1.D0 ) Z1 = Z Z = Z1 - P1 / PP IF ( ABS ( Z - Z1 ). GT . EPS ) GO TO 1 X ( I ) = XM - XL * Z X ( N + 1 - I ) = XM + XL * Z W ( I ) = 2.D0 * XL / (( 1.D0 - Z * Z ) * PP * PP ) W ( N + 1 - I ) = W ( I ) 12 CONTINUE RETURN END SUBROUTINE GAULEG C C SUBROUTINE PLGNFA ( LL , X , Z ) C C PLGNDN BERECHNET ALLE NORMIERTEN ASSOZIIERTEN C LEGENDREFUNKTIONEN VON P00(X) BIS PLL(X) C UND SCHREIBT SIE IN DAS FELD Z C Die Polynome sind wie im ECMWF indiziert, d.h. C P00,P10,P11,P20,P21,P22,... C\tAnsonsten ist die Routine analog zu PLGNDN C X IST DER COSINUS DES ZENITWINKELS ODER C       DER SINUS DER GEOGRAFISCHEN BREITE C IMPLICIT REAL ( A - H , O - Z ) DIMENSION Z ( 0 :(( LL + 3 ) * ( LL + 4 )) / 2 ) C L = LL + 2 I = 1 Z ( 0 ) = 1.D0 FACT = 1.D0 POT = 1.D0 SOMX2 = DSQRT ( 1.D0 - X * X ) DO 14 J = 0 , L DJ = DBLE ( J ) IF ( J . GT . 0 ) THEN FACT = FACT * ( 2.D0 * DJ - 1.D0 ) / ( 2.D0 * DJ ) POT = POT * SOMX2 Z ( I ) = DSQRT (( 2.D0 * DJ + 1.D0 ) * FACT ) * POT I = I + 1 ENDIF IF ( J . LT . L ) THEN Z ( I ) = X * * DSQRT (( 4.D0 * DJ * DJ + 8.D0 * DJ + 3.D0 ) / ( 2.D0 * DJ + 1.D0 )) * Z ( I - 1 ) I = I + 1 ENDIF DK = DJ + 2.D0 DO 14 K = J + 2 , L DDK = ( DK * DK - DJ * DJ ) Z ( I ) = X * DSQRT (( 4.D0 * DK * DK - 1.D0 ) / DDK ) * Z ( I - 1 ) - * DSQRT ((( 2.D0 * DK + 1.D0 ) * ( DK - DJ - 1.D0 ) * ( DK + DJ - 1.D0 )) / * (( 2.D0 * DK - 3.D0 ) * DDK )) * Z ( I - 2 ) DK = DK + 1.D0 I = I + 1 14 CONTINUE RETURN END SUBROUTINE PLGNFA SUBROUTINE DPLGND ( MNAUF , Z , DZ ) C C DPLGND BERECHNET DIE ABLEITUNG DER NORMIERTEN ASSOZIIERTEN C LEGENDREFUNKTIONEN VON P00(X) BIS PLL(X) C UND SCHREIBT SIE IN DAS FELD DZ C DIE REIHENFOLGE IST C P00(X),P01(X),P11(X),P02(X),P12(X),P22(X),..PLL(X) C IMPLICIT REAL ( A - H , O - Z ) DIMENSION Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 ) DIMENSION DZ ( 0 :(( MNAUF + 2 ) * ( MNAUF + 3 )) / 2 ) C I F ( Z ( 0 ). NE . 1.D0 ) THEN WR I TE ( * , * ) 'DPLGND: Z(0) must be 1.0' S TOP E N DIF L L P = 0 L L H = 0 DO 1 I = 0 , MNAUF + 1 DO 2 J = I , MNAUF + 1 IF ( I . EQ . J ) THEN WURZELA = * DSQRT ( DBLE (( J + 1 ) * ( J + 1 ) - I * I ) / DBLE ( 4 * ( J + 1 ) * ( J + 1 ) - 1 )) DZ ( LLH ) = DBLE ( J ) * WURZELA * Z ( LLP + 1 ) ELSE WURZELB = * DSQRT ( DBLE (( J + 1 ) * ( J + 1 ) - I * I ) / DBLE ( 4 * ( J + 1 ) * ( J + 1 ) - 1 )) DZ ( LLH ) = * DBLE ( J ) * WURZELB * Z ( LLP + 1 ) - DBLE ( J + 1 ) * WURZELA * Z ( LLP - 1 ) WURZELA = WURZELB ENDIF LLH = LLH + 1 LLP = LLP + 1 2 CONTINUE LLP = LLP + 1 1\tCON T INUE RETU R N END S UBROUTINE DPLGND * Spectral Filter of Sardeshmukh and Hoskins (1984, MWR) * MM=Spectral truncation of field * MMAX= Spectral truncation of filter * SUBROUTINE SPFILTER ( FELDMN , MM , MMAX ) IMPLICIT NONE INTEGER MM , MMAX , I , J , K , L REAL FELDMN ( 0 :( MM + 1 ) * ( MM + 2 ) - 1 ) REAL KMAX , SMAX , FAK SMAX = 0.1 KMAX =- ALOG ( SMAX ) KMAX = KMAX / ( float ( MMAX ) * float ( MMAX + 1 )) ** 2 c      WRITE(*,*)'alogsmax',alog(smax),'KMAX:',KMAX l = 0 do i = 0 , MM do j = i , MM c          write(*,*) i,j,feld(k),feld(k)*exp(-KMAX*(j*(j+1))**2) if ( j . le . MMAX ) then c               fak=exp(-KMAX*(j*(j+1))**2) fak = 1.0 feldmn ( 2 * l ) = feldmn ( 2 * l ) * fak feldmn ( 2 * l + 1 ) = feldmn ( 2 * l + 1 ) * fak else feldmn ( 2 * l ) = 0. feldmn ( 2 * l + 1 ) = 0. endif l = l + 1 enddo enddo END SUBROUTINE SPFILTER END MODULE PHTOGR","tags":"","loc":"sourcefile/phgrreal.f.html","title":"phgrreal.f – Flex_extract: Calculation of etadot"},{"text":"This File Depends On sourcefile~~grphreal.f~~EfferentGraph sourcefile~grphreal.f grphreal.f sourcefile~phgrreal.f phgrreal.f sourcefile~phgrreal.f->sourcefile~grphreal.f Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which depends upon it. A file \n    is dependent upon another if the latter must be compiled before the former\n    can be. Files Dependent On This One sourcefile~~grphreal.f~~AfferentGraph sourcefile~grphreal.f grphreal.f sourcefile~preconvert.f90 preconvert.f90 sourcefile~grphreal.f->sourcefile~preconvert.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which depends upon it. A file \n    is dependent upon another if the latter must be compiled before the former\n    can be. Modules GRTOPH Source Code grphreal.f Source Code MODULE GRTOPH USE PHTOGR CONTAINS C SUBROUTINE GRPH213 ( CXMN , FELD , WSAVE , IFAX , Z , W , MLAT , * MNAUF , MAXL , MAXB , MLEVEL ) C     DIE ROUTINE F]HRT EINE TRANSFORMATION EINER C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN C     RAUM AUF KUGELKOORDINATEN DURCH C C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF C\t\t\tCXM\t\t = FOURIERKOEFFIZIENTEN - nur ein Hilfsfeld C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN C\t\t\tWSAVE  = Working Array fuer Fouriertransformation C     Z \t = LEGENDREFUNKTIONSWERTE C C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN C IMPLICIT REAL ( A - H , O - Z ) C\t\t\tAnzahl der Gitterpunkte pro Breitenkreis des reduzierten C\t\t\tGauss'schen Gitters INTE G ER MLAT ( MAXB ), ISIZE , IFAX ( 10 , MAXB ) C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL * 8 Z ( MAXB / 2 , 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 ) C      LOGICAL*1 USED(((216*217)/2+1)*160) DIMENSION CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MLEVEL ) DIMENSION WSAVE ( 8 * MAXB + 15 , MAXB / 2 ) REAL * 8 W ( MAXB ) DIMENSION IND ( MAXB ) IND ( 1 ) = 0 DO 6 J = 2 , MAXB / 2 IND ( j ) = IND ( J - 1 ) + MLAT ( J - 1 ) 6 CONTINUE !$OMP PARALLEL DO SCHEDULE(DYNAMIC) DO 16 L = 1 , MLEVEL CALL GRPHSUB ( L , IND , CXMN , FELD , WSAVE , IFAX , Z , W , MLAT , * MNAUF , MAXL , MAXB , MLEVEL ) 16 CONTINUE !$omp end parallel do RETURN END SUBROUTINE GRPH213 C SUBROUTINE GRPHSUB ( L , IND , CXMN , FELD , WSAVE , IFAX , Z , W , MLAT , * MNAUF , MAXL , MAXB , MLEVEL ) C     DIE ROUTINE F]HRT EINE TRANSFORMATION EINER C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN C     RAUM AUF KUGELKOORDINATEN DURCH C C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF C\t\t\tCXM\t\t = FOURIERKOEFFIZIENTEN - nur ein Hilfsfeld C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN C\t\t\tWSAVE  = Working Array fuer Fouriertransformation C     Z \t = LEGENDREFUNKTIONSWERTE C C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN C IMPLICIT REAL ( A - H , O - Z ) C    FELD DER FOURIERKOEFFIZIENTEN REAL CXMS ( 4 * ( MNAUF + 1 )) REAL CXMA ( 4 * ( MNAUF + 1 )) REAL , ALLOCATABLE :: CXM (:,:) C\t\t\tAnzahl der Gitterpunkte pro Breitenkreis des reduzierten C\t\t\tGauss'schen Gitters IN T EGER MLAT ( MAXB ), ISIZE C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE REAL Z ( MAXB / 2 , 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 ) C      LOGICAL*1 USED(((216*217)/2+1)*160) REAL CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) REAL FELD ( MAXL , MLEVEL ) REAL WSAVE ( 8 * MAXB + 15 , MAXB / 2 ) INTEGER IFAX ( 10 , MAXB ) REAL W ( MAXB ) INTEGER IND ( MAXB ) ALLOCATE ( CXM ( 4 * MAXB , MAXB )) DO 5 J = 1 , MAXB / 2 CXMS ( 1 : MLAT ( J )) = FELD ( IND ( J ) + 1 : IND ( J ) + MLAT ( J ), L ) C ALL RFOUFTR ( CXMS , WSAVE ( 1 , J ), IFAX (:, J ), MNAUF , MLAT ( J ), 1 ) CXMA ( 1 : MLAT ( J )) = FELD ( MAXL - IND ( J ) - MLAT ( J ) + 1 : MAXL - IND ( J ), L ) C ALL RFOUFTR ( CXMA , * WSAVE ( 1 , J ), IFAX (:, J ), MNAUF , MLAT ( J ), 1 ) D O 4 I = 1 , 2 * ( MNAUF + 1 ) CXM ( I , J ) = CXMS ( I ) + CXMA ( I ) CXM ( I , MAXB + 1 - J ) = CXMS ( I ) - CXMA ( I ) 4\t\t\tC O NTINUE 5 CONTINUE CALL LGTR213 ( CXMN ( 0 , L ), CXM , Z , W , MLAT , MNAUF , MAXB ) DEALLOCATE ( CXM ) RETURN END SUBROUTINE GRPHSUB C SUBROUTINE LGTR213 ( CXMN , CXM , Z , W , MLAT , MNAUF , MAXB ) IMPLICIT REAL ( A - H , O - Z ) INTEGER MLAT ( MAXB ) DIMENSION CXM ( 0 : 4 * MAXB - 1 , MAXB ) DIMENSION CXMN ( 0 : 2 * ((( MNAUF + 1 ) * MNAUF ) / 2 + MNAUF ) + 1 ) REAL * 8 Z ( MAXB / 2 , 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 ) REAL * 8 W ( MAXB ), CR , CI , HILF LOGICAL EVEN C C     DIESE ROUTINE BERECHNET DIE KFFKs CXMN C LL = 0 LL P = 0 DO 1 I = 0 , MNAUF KM = 0 9 KM = KM + 1 IF ( MLAT ( KM ). LE . 2 * I ) THEN GOTO 9 ENDIF DO 2 J = I , MNAUF CR = 0 CI = 0 EVEN = MOD ( I + J , 2 ). EQ . 0 IF ( EVEN ) THEN DO 3 K = KM , MAXB / 2 HILF = W ( K ) * Z ( K , LLP ) CR = CR + CXM ( 2 * I , K ) * HILF CI = CI + CXM ( 2 * I + 1 , K ) * HILF 3 CONTINUE ELSE DO 4 K = KM , MAXB / 2 HILF = W ( K ) * Z ( K , LLP ) CR = CR + CXM ( 2 * I , MAXB + 1 - K ) * HILF CI = CI + CXM ( 2 * I + 1 , MAXB + 1 - K ) * HILF 4 CONTINUE ENDIF 5 CXMN ( 2 * LL ) = CR CXMN ( 2 * LL + 1 ) = CI LL = LL + 1 LLP = LLP + 1 2 CONTINUE LLP = LLP + 2 1 CONTINUE RETURN END SUBROUTINE LGTR213 C C SUBROUTINE RFOUFTR ( CXM , TRIGS , IFAX , MNAUF , MAXL , ISIGN ) C     BERECHNET DIE FOURIERSUMME MIT EINEM FFT-ALGORITHMUS IMPLICIT REAL ( A - H , O - Z ) DIMENSION CXM ( 0 : 2 * MAXL - 1 ) DIMENSION FELD ( MAXL ), TRIGS ( 2 * MAXL ) DIMENSION WSAVE ( MAXAUF ) INTEGER IFAX ( 10 ) C NORMIERUNG... WSAVE ( 1 ) = CXM ( MAXL - 1 ) CXM ( 1 : MAXL ) = CXM ( 0 : MAXL - 1 ) / 2 CXM ( 0 ) = WSAVE ( 1 ) / 2 !      CALL CFFTF(MAXL,CXM,WSAVE) CALL FFT99 ( CXM , WSAVE , TRIGS , IFAX , 1 , 1 , MAXL , 1 , - 1 ) RETURN END SUBROUTINE RFOUFTR END MODULE GRTOPH","tags":"","loc":"sourcefile/grphreal.f.html","title":"grphreal.f – Flex_extract: Calculation of etadot"},{"text":"Files Dependent On This One sourcefile~~rwgrib2.f90~~AfferentGraph sourcefile~rwgrib2.f90 rwGRIB2.f90 sourcefile~preconvert.f90 preconvert.f90 sourcefile~rwgrib2.f90->sourcefile~preconvert.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which depends upon it. A file \n    is dependent upon another if the latter must be compiled before the former\n    can be. Modules RWGRIB2 Source Code rwGRIB2.f90 Source Code MODULE RWGRIB2 CONTAINS SUBROUTINE READLATLON ( FILENAME , FELD , MAXL , MAXB , MLEVEL , MPAR ) USE GRIB_API IMPLICIT NONE integer :: ifile integer :: iret integer :: n , mk , parid , nm integer :: i , k integer , dimension (:), allocatable :: igrib integer :: numberOfPointsAlongAParallel integer :: numberOfPointsAlongAMeridian real , dimension (:), allocatable :: values integer :: numberOfValues real , dimension ( maxl , maxb , mlevel ) :: feld integer :: maxl , maxb , mlevel , mstride , mpar (:), irest , div , level integer :: l ( size ( mpar )) character * ( * ) :: filename feld = 0. call grib_open_file ( ifile , TRIM ( FILENAME ), 'r' ) ! count the messages in the file call grib_count_in_file ( ifile , n ) allocate ( igrib ( n )) igrib =- 1 ! Load the messages from the file. DO i = 1 , n call grib_new_from_file ( ifile , igrib ( i ), iret ) END DO ! we can close the file call grib_close_file ( ifile ) nm = size ( mpar ) div = mlevel / nm l = 0 ! Loop on all the messages in memory iloop : DO i = 1 , n !      write(*,*) 'processing message number ',i !     get as a integer call grib_get ( igrib ( i ), 'numberOfPointsAlongAParallel' , & numberOfPointsAlongAParallel ) !     get as a integer call grib_get ( igrib ( i ), 'numberOfPointsAlongAMeridian' , & numberOfPointsAlongAMeridian ) call grib_get ( igrib ( i ), 'numberOfVerticalCoordinateValues' , mk ) call grib_get_size ( igrib ( i ), 'values' , numberOfValues ) !      write(*,*) 'numberOfValues=',numberOfValues allocate ( values ( numberOfValues ), stat = iret ) !     get data values call grib_get ( igrib ( i ), 'values' , values ) call grib_get ( igrib ( i ), 'paramId' , parid ) call grib_get ( igrib ( i ), 'level' , level ) kloop : do k = 1 , nm if ( parid . eq . mpar ( k )) then !         l(k)=l(k)+1 feld (:,:,( k - 1 ) * div + level ) = reshape ( values ,( / maxl , maxb / )) !         print*,(k-1)*div+l(k),parid exit kloop endif enddo kloop if ( k . gt . nm . and . parid . ne . mpar ( nm )) then write ( * , * ) k , nm , parid , mpar ( nm ) write ( * , * ) 'ERROR readlatlon: parameter ' , parid , 'is not' , mpar stop endif !      print*,i END DO iloop write ( * , * ) 'readlatlon: ' , i - 1 , ' records read' DO i = 1 , n call grib_release ( igrib ( i )) END DO deallocate ( values ) deallocate ( igrib ) END SUBROUTINE READLATLON SUBROUTINE WRITELATLON ( iunit , igrib , ogrib , FELD , MAXL , MAXB , MLEVEL ,& MLEVELIST , MSTRIDE , MPAR ) USE GRIB_API IMPLICIT NONE INTEGER IFIELD , MLEVEL , MNAUF , I , J , K , L , MSTRIDE , IERR , JOUT INTEGER MPAR ( MSTRIDE ), MAXL , MAXB , LEVMIN , LEVMAX INTEGER IUNIT , igrib , ogrib REAL ZSEC4 ( MAXL * MAXB ) REAL FELD ( MAXL , MAXB , MLEVEL ) CHARACTER * ( * ) MLEVELIST INTEGER ILEVEL ( MLEVEL ), MLINDEX ( MLEVEL + 1 ), LLEN ! parse MLEVELIST LLEN = len ( trim ( MLEVELIST )) if ( index ( MLEVELIST , 'to' ) . ne . 0 . or . index ( MLEVELIST , 'TO' ) . ne . 0 ) THEN i = index ( MLEVELIST , '/' ) read ( MLEVELIST ( 1 : i - 1 ), * ) LEVMIN i = index ( MLEVELIST , '/' ,. true .) read ( MLEVELIST ( i + 1 : LLEN ), * ) LEVMAX l = 0 do i = LEVMIN , LEVMAX l = l + 1 ILEVEL ( l ) = i enddo else l = 1 MLINDEX ( 1 ) = 0 do i = 1 , LLEN if ( MLEVELIST ( i : i ) . eq . '/' ) THEN l = l + 1 MLINDEX ( l ) = i endif enddo MLINDEX ( l + 1 ) = LLEN + 1 do i = 1 , l read ( MLEVELIST ( MLINDEX ( i ) + 1 : MLINDEX ( i + 1 ) - 1 ), * ) ILEVEL ( i ) enddo endif DO k = 1 , l call grib_set ( igrib , \"level\" , ILEVEL ( k )) DO j = 1 , MSTRIDE call grib_set ( igrib , \"paramId\" , MPAR ( j )) !         if(MPAR(j) .eq. 87) then !           call grib_set(igrib,\"shortName\",\"etadot\") !           call grib_set(igrib,\"units\",\"Pa,s**-1\") !         endif !         if(MPAR(j) .eq. 77) then !           call grib_set(igrib,\"shortName\",\"etadot\") !           call grib_set(igrib,\"units\",\"s**-1\") !         endif if ( l . ne . mlevel ) then zsec4 ( 1 : maxl * maxb ) = RESHAPE ( FELD (:,:, ILEVEL ( k )),( / maxl * maxb / )) else zsec4 ( 1 : maxl * maxb ) = RESHAPE ( FELD (:,:, k ),( / maxl * maxb / )) endif call grib_set ( igrib , \"values\" , zsec4 ) call grib_write ( igrib , iunit ) ENDDO ENDDO END SUBROUTINE WRITELATLON SUBROUTINE READSPECTRAL ( FILENAME , CXMN , MNAUF , MLEVEL ,& MAXLEV , MPAR , A , B ) USE GRIB_API IMPLICIT NONE integer :: ifile integer :: iret integer :: n , mk , div , nm , k integer :: i , j , parid integer , dimension (:), allocatable :: igrib real , dimension (:), allocatable :: values integer :: numberOfValues , maxlev REAL :: A ( MAXLEV + 1 ), B ( MAXLEV + 1 ), pv ( 2 * MAXLEV + 2 ) REAL :: CXMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , MLEVEL ) integer :: maxl , maxb , mlevel , mstride , mpar (:), mnauf , ioffset , ipar , ilev , l ( size ( mpar )) character * ( * ) :: filename call grib_open_file ( ifile , TRIM ( FILENAME ), 'r' ) ! count the messages in the file call grib_count_in_file ( ifile , n ) allocate ( igrib ( n )) igrib =- 1 ! Load the messages from the file. DO i = 1 , n call grib_new_from_file ( ifile , igrib ( i ), iret ) END DO ! we can close the file call grib_close_file ( ifile ) l = 0 ! Loop on all the messages in memory iloop : DO i = 1 , n ! write(*,*) 'processing message number ',i !     get as a integer call grib_get ( igrib ( i ), 'pentagonalResolutionParameterJ' , j ) call grib_get_size ( igrib ( i ), 'values' , numberOfValues ) !   write(*,*) 'numberOfValues=',numberOfValues call grib_get ( igrib ( i ), 'numberOfVerticalCoordinateValues' , mk ) call grib_get ( igrib ( i ), 'level' , ilev ) call grib_get ( igrib ( i ), 'pv' , pv ) allocate ( values ( numberOfValues ), stat = iret ) !     get data values call grib_get ( igrib ( i ), 'values' , values ) !      IOFFSET=mod(i-1,MSTRIDE)*(mk/2-1) !           CXMN(:,IOFFSET+ilev)=values(1:(MNAUF+1)*(MNAUF+2)) call grib_get ( igrib ( i ), 'paramId' , parid ) nm = size ( mpar ) div = mlevel / nm kloop : do k = 1 , nm if ( parid . eq . mpar ( k )) then l ( k ) = l ( k ) + 1 cxmn (:,( k - 1 ) * div + l ( k )) = values ( 1 :( MNAUF + 1 ) * ( MNAUF + 2 )) !         print*,(k-1)*div+l(k),parid exit kloop endif enddo kloop if ( k . gt . nm . and . parid . ne . mpar ( nm )) then write ( * , * ) k , nm , parid , mpar ( nm ) write ( * , * ) 'ERROR readspectral: parameter ' , parid , 'is not' , mpar stop endif !      print*,i END DO iloop write ( * , * ) 'readspectral: ' , i - 1 , ' records read' DO i = 1 , n call grib_release ( igrib ( i )) END DO deallocate ( values ) deallocate ( igrib ) A = pv ( 1 : 1 + MAXLEV ) B = pv ( 2 + MAXLEV : 2 * MAXLEV + 2 ) END SUBROUTINE READSPECTRAL END MODULE RWGRIB2","tags":"","loc":"sourcefile/rwgrib2.f90.html","title":"rwGRIB2.f90 – Flex_extract: Calculation of etadot"},{"text":"This File Depends On sourcefile~~preconvert.f90~~EfferentGraph sourcefile~preconvert.f90 preconvert.f90 sourcefile~grphreal.f grphreal.f sourcefile~grphreal.f->sourcefile~preconvert.f90 sourcefile~phgrreal.f phgrreal.f sourcefile~phgrreal.f->sourcefile~preconvert.f90 sourcefile~phgrreal.f->sourcefile~grphreal.f sourcefile~rwgrib2.f90 rwGRIB2.f90 sourcefile~rwgrib2.f90->sourcefile~preconvert.f90 Help × Graph Key Nodes of different colours represent the following: Graph Key Source File Source File This Page's Entity This Page's Entity Solid arrows point from a file to a file which depends upon it. A file \n    is dependent upon another if the latter must be compiled before the former\n    can be. Programs PRECONVERT Functions IA Subroutines STATIS Source Code preconvert.f90 Source Code PROGRAM PRECONVERT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                                                                 ! ! PROGRAM PRECONVERT - PREPARES INPUT DATA FOR POP MODEL METEOR-  ! !                      OLOGICAL PREPROCESSOR                      ! !                                                                 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                                                                 ! ! CALCULATION OF ETAPOINT ON A REGULAR LAMDA/PHI GRID AND WRITING ! ! U,V,ETAPOINT,T,PS,Q,SD,MSL,TCC,10U, 10V, 2T,2D,LSP,CP,SSHF,SSR, ! ! EWSS,NSSS TO AN OUTPUT FILE (GRIB 1 or 2 FORMAT).               ! !                                                                 ! ! AUTHORS: L. HAIMBERGER, G. WOTAWA, 1994-04                      ! !                     adapted: A. BECK                            ! !                     2003-05-11                                  ! !          L. Haimberger 2006-12    V2.0                          ! !                    modified to handle arbitrary regular grids   ! !                    and T799 resolution data                     ! !          L. Haimberger 2010-03    V4.0                          ! !                    modified to grib edition 2 fields            ! !                    and T1279 resolution data                    ! !                                                                 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                                                                 ! ! DESCRIPTION OF NEEDED INPUT:                                    ! !                                                                 ! ! UNIT  FILE      PARAMETER(S)    DATA REPRESENTATION             ! !                                                                 ! ! 11    fort.11   T,U,V           regular lamda phi grid          ! ! 12    fort.12   D               regular lamda phi grid          ! ! 13    fort.13   LNSP          fort.13  spherical harmonics             ! ! 14    fort.14   SD,MSL,TCC,10U,                                 ! !                 10V,2T,2D       regular lamda phi grid          ! ! 16    fort.16   LSP,CP,SSHF,                                    ! !                 SSR,EWSS,NSSS   regular lamda phi grid          ! ! 17    fort.17   Q               regular lamda phi grid          ! !                                                                 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                                                                 ! ! DESCRIPTION OF OUTPUT:                                          ! !                                                                 ! ! UNIT  FILE      PARAMETER(S)    DATA REPRESENTATION             ! !                                                                 ! ! 15    fort.15   U,V,ETA,T,PS,                                   ! !                 Q,SD,MSL,TCC,                                   ! !                 10U,10V,2T,2D,  regular lamda phi grid          ! !                 LSP,CP,SSHF,                                    ! !                 SSR,EWSS,NSSS                                   ! !                                                                 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! USE PHTOGR USE GRTOPH USE FTRAFO USE RWGRIB2 USE GRIB_API IMPLICIT NONE REAL , ALLOCATABLE , DIMENSION (:,:) :: LNPS REAL , ALLOCATABLE , DIMENSION (:,:) :: Z REAL , ALLOCATABLE , DIMENSION (:,:,:) :: T , UV , UV2 REAL , ALLOCATABLE , DIMENSION (:,:,:) :: QA , OM , OMR REAL , ALLOCATABLE , DIMENSION (:,:,:) :: DIV , ETA , ETAR REAL , ALLOCATABLE , DIMENSION (:,:) :: DPSDL , DPSDM REAL , ALLOCATABLE , DIMENSION (:,:,:) :: PS , DPSDT REAL , ALLOCATABLE , DIMENSION (:,:,:) :: SURF , FLUX , OROLSM REAL , ALLOCATABLE , DIMENSION (:) :: WSAVE , H , SINL , COSL , WSAVE2 REAL , ALLOCATABLE , DIMENSION (:) :: BREITE , GBREITE , AK , BK , pv ! Arrays for Gaussian grid calculations REAL :: X1 , X2 , RMS , MW , SIG , LAM REAL , ALLOCATABLE :: CUA (:,:,:), CVA (:,:,:) REAL , ALLOCATABLE , DIMENSION (:,:) :: P , PP !,P2 REAL , ALLOCATABLE , DIMENSION (:,:) :: XMN , HILFUV REAL , ALLOCATABLE , DIMENSION (:) :: LNPMN , LNPMN2 , LNPMN3 REAL , ALLOCATABLE , DIMENSION (:) :: WEIGHT REAL , ALLOCATABLE , DIMENSION (:,:) :: UGVG REAL , ALLOCATABLE , DIMENSION (:,:) :: DG , ETAG REAL , ALLOCATABLE , DIMENSION (:,:) :: GWSAVE REAL , ALLOCATABLE , DIMENSION (:) :: PSG , HILF ! end arrays for Gaussian grid calculations INTEGER , ALLOCATABLE , DIMENSION (:) :: MLAT , MPSURF , MPFLUX , MPORO , MPAR INTEGER , ALLOCATABLE :: GIFAX (:,:) REAL PI , COSB , DAK , DBK , P00 REAL URLAR8 , JMIN1 , LLLAR8 , MAXBMIN1 , PIR8 , DCOSB INTEGER I , J , K , L , IERR , M , LTEST , MK , NGI , NGJ INTEGER MFLUX , MSURF , MORO INTEGER LUNIT , LUNIT2 INTEGER MAXL , MAXB , MLEVEL , LEVOUT , LEVMIN , LEVMAX INTEGER MOMEGA , MOMEGADIFF , MGAUSS , MSMOOTH , MNAUF , META , METADIFF INTEGER MDPDETA , METAPAR REAL RLO0 , RLO1 , RLA0 , RLA1 CHARACTER * 300 MLEVELIST INTEGER MAUF , MANF , IFAX ( 10 ) INTEGER IGRIB ( 1 ), iret , ogrib CHARACTER * 80 FILENAME NAMELIST / NAMGEN / & MAXL , MAXB , & MLEVEL , MLEVELIST , MNAUF , METAPAR , & RLO0 , RLO1 , RLA0 , RLA1 , & MOMEGA , MOMEGADIFF , MGAUSS , MSMOOTH , META , METADIFF ,& MDPDETA LTEST = 1 call posnam ( 4 , 'NAMGEN' ) read ( 4 , NAMGEN ) MAUF = INT ( 36 0. * ( REAL ( MAXL ) - 1. ) / ( RLO1 - RLO0 ) + 0.0001 ) !      PRINT*, MAUF MANF = INT ( REAL ( MAUF ) / 36 0. * ( 36 0. + RLO0 ) + 1.0001 ) IF ( MANF . gt . MAUF ) MANF = MANF - MAUF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                       ALLOCATE VARIABLES                        ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ALLOCATE ( LNPS ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , 1 )) ALLOCATE ( H ( 0 :( MNAUF + 2 ) * ( MNAUF + 3 ) / 2 )) ALLOCATE ( OM ( MAXL , MAXB , MLEVEL )) ALLOCATE ( ETA ( MAXL , MAXB , MLEVEL )) ALLOCATE ( PS ( MAXL , MAXB , 1 ), DPSDT ( MAXL , MAXB , 1 )) ALLOCATE ( WSAVE ( 4 * MAUF + 15 ), WSAVE2 ( 4 * MAUF + 15 )) ALLOCATE ( BREITE ( MAXB ), AK ( MLEVEL + 1 ), BK ( MLEVEL + 1 ), pv ( 2 * mlevel + 2 )) ALLOCATE ( MPAR ( 2 )) ALLOCATE ( COSL ( MAXL ), SINL ( MAXL )) ALLOCATE ( CUA ( 2 , 4 , MLEVEL ), CVA ( 2 , 4 , MLEVEL )) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !     GAUSS STUFF ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF ( MGAUSS . EQ . 1 ) THEN LUNIT = 0 FILENAME = 'fort.18' call grib_open_file ( LUNIT , TRIM ( FILENAME ), 'r' ) call grib_new_from_file ( LUNIT , igrib ( 1 ), iret ) ! we can close the file call grib_close_file ( LUNIT ) !      call grib_get(igrib(1),'gridType', j) NGJ = MNAUF + 1 ALLOCATE ( GWSAVE ( 8 * NGJ + 15 , NGJ / 2 )) ALLOCATE ( GIFAX ( 10 , NGJ )) ALLOCATE ( GBREITE ( NGJ ), WEIGHT ( NGJ )) ALLOCATE ( MLAT ( NGJ )) ALLOCATE ( P ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , NGJ / 2 )) ALLOCATE ( PP ( NGJ / 2 , 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 )) ALLOCATE ( Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , MAXB )) call grib_get ( igrib ( 1 ), 'numberOfPointsAlongAMeridian' , NGJ ) !     get as a integer call grib_get ( igrib ( 1 ), 'pl' , MLAT ) NGI = SUM ( MLAT ) call grib_get ( igrib ( 1 ), 'numberOfVerticalCoordinateValues' , mk ) IF ( mk / 2 - 1 . ne . MLEVEL ) THEN WRITE ( * , * ) 'FATAL: Number of model levels' , mk , & ' does not agree with' , MLEVEL , ' in namelist' STOP ENDIF call grib_get ( igrib ( 1 ), 'pv' , pv ) AK = pv ( 1 : 1 + MLEVEL ) BK = pv ( 2 + MLEVEL : 2 * MLEVEL + 2 ) ALLOCATE ( LNPMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 )) ALLOCATE ( LNPMN2 ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 )) ALLOCATE ( UGVG ( NGI , 2 * MLEVEL ), HILFUV ( 2 * MAXL , 2 )) ALLOCATE ( DPSDL ( NGI , 1 ), DPSDM ( NGI , 1 )) ALLOCATE ( PSG ( NGI ), HILF ( NGI )) ALLOCATE ( UV ( MAXL , MAXB , 2 * MLEVEL )) !      ALLOCATE (UV2(MAXL, MAXB, 2*MLEVEL)) ALLOCATE ( XMN ( 0 :( MNAUF + 1 ) * ( MNAUF + 2 ) - 1 , 2 * MLEVEL )) ALLOCATE ( DG ( NGI , MLEVEL ), ETAG ( NGI , MLEVEL )) ! Initialisieren  Legendretransformation !\tauf das LaT/LON Gitter PI = ACOS ( - 1.D0 ) !$OMP PARALLEL DO DO 20 J = 1 , MAXB BREITE ( J ) = SIN (( RLA1 - ( J - 1.D0 ) * ( RLA1 - RLA0 ) / ( MAXB - 1 )) * PI / 18 0.D0 ) CALL PLGNFA ( MNAUF , BREITE ( J ), Z ( 0 , J )) 20 CONTINUE !$OMP END PARALLEL DO ! Avoid possible Pole problem !      IF(RLA0 .EQ. -90.0) BREITE(MAXB)=sin(-89.99*PI/180.d0) !      IF(RLA1 .EQ. 90.0)  BREITE(1)=sin(89.99*PI/180.d0) ! Initialisation of fields for  FFT and Legendre transformation !\tto  Gaussian grid and back to phase space X1 =- 1.D0 X2 = 1.D0 CALL GAULEG ( X1 , X2 , GBREITE , WEIGHT , NGJ ) !$OMP PARALLEL DO PRIVATE(M) DO J = 1 , NGJ / 2 CALL PLGNFA ( MNAUF , GBREITE ( J ), P (:, J )) DO M = 0 ,( MNAUF + 3 ) * ( MNAUF + 4 ) / 2 PP ( J , M ) = P ( M , J ) ENDDO ENDDO !$OMP END PARALLEL DO !       MPAR(1)=152 FILENAME = 'fort.12' CALL READSPECTRAL ( FILENAME , LNPMN , MNAUF , 1 , MLEVEL ,( / 152 / ), AK , BK ) !      goto 111 CALL SET99 ( WSAVE , IFAX , mauf ) CALL PHGCUT ( LNPMN , PS , WSAVE , IFAX , Z , & MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , 1 ) CALL STATIS ( MAXL , MAXB , 1 , EXP ( PS ), RMS , MW , SIG ) WRITE ( * , '(A12,3F12.4)' ) 'STATISTICS: ' , RMS , MW , SIG DO J = 1 , NGJ / 2 CALL SET99 ( GWSAVE ( 1 , J ), GIFAX ( 1 , J ), MLAT ( J )) ENDDO CALL PHGR213 ( LNPMN , HILF , GWSAVE , GIFAX , P , MLAT , MNAUF , NGI , NGJ , 1 ) PSG = HILF CALL GRPH213 ( LNPMN2 , PSG , GWSAVE , GIFAX , PP , WEIGHT , MLAT , & MNAUF , NGI , NGJ , 1 ) CALL PHGR213 ( LNPMN2 , HILF , GWSAVE , GIFAX , P , MLAT , MNAUF , NGI , NGJ , 1 ) HILF = exp ( PSG ) - exp ( HILF ) CALL STATIS ( NGI , 1 , 1 , HILF , RMS , MW , SIG ) WRITE ( * , '(A12,3F11.4)' ) 'STATISTICS: ' , RMS , MW , SIG PSG = EXP ( PSG ) HILF = PSG CALL STATIS ( NGI , 1 , 1 , HILF , RMS , MW , SIG ) WRITE ( * , '(A12,3F11.4)' ) 'STATISTICS: ' , RMS , MW , SIG 111 FILENAME = 'fort.10' CALL READSPECTRAL ( FILENAME , & XMN , MNAUF , 2 * MLEVEL , MLEVEL ,( / 131 , 132 / ), AK , BK ) !\tTransformieren des Windes auf das Gaussgitter CALL PHGR213 ( XMN , UGVG , GWSAVE , GIFAX , P , MLAT , MNAUF , NGI , NGJ , 2 * MLEVEL ) DO K = 1 , MLEVEL ! North Pole CALL JSPPOLE ( XMN (:, K ), 1 , MNAUF ,. TRUE ., CUA (:,:, K )) CALL JSPPOLE ( XMN (:, MLEVEL + K ), 1 , MNAUF ,. TRUE ., CVA (:,:, K )) ! South Pole CALL JSPPOLE ( XMN (:, K ), - 1 , MNAUF ,. TRUE ., CUA (:, 3 : 4 , K )) CALL JSPPOLE ( XMN (:, MLEVEL + K ), - 1 , MNAUF ,. TRUE ., CVA (:, 3 : 4 , K )) ENDDO DO K = 1 , 2 * MLEVEL IF ( MSMOOTH . ne . 0 ) CALL SPFILTER ( XMN (:, K ), MNAUF , MSMOOTH ) ENDDO CALL PHGCUT ( XMN , UV , WSAVE , IFAX , Z , & MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , 2 * MLEVEL ) 112 FILENAME = 'fort.13' CALL READSPECTRAL ( FILENAME , XMN , MNAUF , MLEVEL , MLEVEL ,( / 155 / ), AK , BK ) !\tTransformieren der horizontalen Divergenz auf das Gaussgitter CALL PHGR213 ( XMN , DG , GWSAVE , GIFAX , P , MLAT , MNAUF , NGI , NGJ , MLEVEL ) !\tBerechnung des Gradienten des Logarithmus des Bodendrucks !       auf dem Gaussgitter CALL PHGRAD ( LNPMN , DPSDL , DPSDM , GWSAVE , GIFAX , P , H , MLAT , MNAUF , NGI , NGJ , 1 ) !\tBerechnung der Vertikalgeschwindigkeit auf dem Gaussgitter CALL CONTGL ( HILF , DPSDL , DPSDM , DG , UGVG (:, 1 ), UGVG (:, MLEVEL + 1 ), & GBREITE , ETAG , MLAT , AK , BK , NGI , NGJ , MLEVEL ) CALL GRPH213 ( XMN , ETAG , GWSAVE , GIFAX , PP , WEIGHT , MLAT , & MNAUF , NGI , NGJ , MLEVEL ) DO K = 1 , MLEVEL IF ( MSMOOTH . ne . 0 ) CALL SPFILTER ( XMN (:, K ), MNAUF , MSMOOTH ) ENDDO CALL PHGCUT ( XMN , ETA , WSAVE , IFAX , Z , MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , MLEVEL ) CALL GRPH213 ( XMN , HILF , GWSAVE , GIFAX , PP , WEIGHT , MLAT , MNAUF , NGI , NGJ , 1 ) IF ( MSMOOTH . ne . 0 ) CALL SPFILTER ( XMN (:, 1 ), MNAUF , MSMOOTH ) CALL PHGCUT ( XMN , DPSDT , WSAVE , IFAX , Z , MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , 1 ) !       GOTO 114 CALL STATIS ( MAXL , MAXB , 1 , DPSDT , RMS , MW , SIG ) WRITE ( * , '(A12,3F11.4)' ) 'STATISTICS DPSDT: ' , RMS , MW , SIG IF ( MOMEGADIFF . ne . 0 ) THEN !\tBerechnung von Omega auf dem Gaussgitter CALL OMEGA ( PSG , DPSDL , DPSDM , DG , UGVG (:, 1 ), UGVG (:, MLEVEL + 1 ), & GBREITE , ETAG , MLAT , AK , BK , NGI , NGJ , MLEVEL ) CALL GRPH213 ( XMN , ETAG , GWSAVE , GIFAX , PP , WEIGHT , MLAT ,& MNAUF , NGI , NGJ , MLEVEL ) DO K = 1 , MLEVEL IF ( MSMOOTH . ne . 0 ) CALL SPFILTER ( XMN (:, K ), MNAUF , MSMOOTH ) ENDDO CALL PHGCUT ( XMN , OM , WSAVE , IFAX , Z , MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , MLEVEL ) ENDIF !MOMEGA CALL GRPH213 ( XMN , PSG , GWSAVE , GIFAX , PP , WEIGHT , MLAT , MNAUF , NGI , NGJ , 1 ) CALL PHGCUT ( XMN , PS , WSAVE , IFAX , Z , MNAUF , MNAUF , MAUF , MANF , MAXL , MAXB , 1 ) CALL STATIS ( MAXL , MAXB , 1 , PS , RMS , MW , SIG ) WRITE ( * , '(A12,3F11.4)' ) 'STATISTICS: ' , RMS , MW , SIG 114 DEALLOCATE ( HILF , PSG , DPSDL , DPSDM , ETAG , DG , LNPMN ) !      ALLOCATE (UV(MAXL, MAXB, 2*MLEVEL)) !\tCALL GRPH213(XMN,UGVG,GWSAVE,GIFAX,PP,WEIGHT,MLAT, !     *MNAUF,NGI,NGJ,2*MLEVEL) !        DO K=1,2*MLEVEL !          IF(MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,K),MNAUF,MSMOOTH) !        ENDDO !        CALL PHGCUT(XMN,UV,WSAVE,IFAX,Z, !     *MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,2*MLEVEL) DEALLOCATE ( PP , P , UGVG , MLAT , GBREITE , WEIGHT , GWSAVE , XMN ) !        CALL ETAGAUSS(Z,WSAVE !     *,BREITE,UV,ETA,OM,PS, !     *MAUF,MAXB,MAXL,MANF,MNAUF,MLEVEL,MSMOOTH) ELSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !          READING OF PREPARED METEOROLOGICAL FIELDS              ! !                                                                 ! !          THE FOLLOWING FIELDS ARE EXPECTED:                     ! !                                                                 ! !          UNIT 11: T,U,V        (REGULAR GRID)                   ! !          UNIT 17: Q            (REGULAR GRID)                   ! !          UNIT 13: D            (REGULAR GRID)                   ! !          UNIT 12: LNSP         (SPHERICAL HARMONICS)            ! !          UNIT 14: SURFACE DATA (REGULAR GRID)                   ! !          UNIT 16: FLUX DATA    (REGULAR GRID)                   ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ALLOCATE ( MLAT ( MAXB )) MLAT = MAXL ALLOCATE ( Z ( 0 :(( MNAUF + 3 ) * ( MNAUF + 4 )) / 2 , 1 )) ALLOCATE ( DPSDL ( MAXL , MAXB ), DPSDM ( MAXL , MAXB )) ALLOCATE ( UV ( MAXL , MAXB , 2 * MLEVEL ), DIV ( MAXL , MAXB , MLEVEL )) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                  READING OF SURFACE PRESSURE                    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FILENAME = 'fort.12' CALL READSPECTRAL ( FILENAME , LNPS , MNAUF , 1 , MLEVEL ,( / 152 / ), AK , BK ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                      READING OF U,V                      ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! OPENING OF UNBLOCKED GRIB FILE ! FILENAME = 'fort.10' CALL READLATLON ( FILENAME , UV , MAXL , MAXB , 2 * MLEVEL ,( / 131 , 132 / )) PI = ACOS ( - 1.D0 ) DO J = 1 , MAXB BREITE ( J ) = SIN (( RLA1 - ( J - 1.D0 ) * ( RLA1 - RLA0 ) / ( MAXB - 1 )) * PI / 18 0.D0 ) ENDDO ! Avoid possible Pole problem !      IF(RLA0 .EQ. -90.0) BREITE(MAXB)=sin(-89.99*PI/180.d0) !      IF(RLA1 .EQ. 90.0)  BREITE(1)=sin(89.99*PI/180.d0) DO K = 1 , 2 * MLEVEL DO J = 1 , MAXB COSB = SQRT ( 1.0 - ( BREITE ( J )) * ( BREITE ( J ))) IF ( RLA0 . EQ . - 9 0.0 . AND . J . EQ . MAXB . OR . & RLA1 . EQ . 9 0.0 . AND . J . EQ . 1 ) then UV (:, J , K ) = UV (:, J , K ) / 1.D6 else UV (:, J , K ) = UV (:, J , K ) * COSB endif ENDDO ENDDO !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     READING OF LNSP on grid                ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! For debugging only !      FILENAME='LNSPG_G.20060330.600' !      INQUIRE(FILE=FILENAME,EXIST=EX) !      CALL READLATLON(FILENAME,QA, !     *MAXL,MAXB,1,1,(/152/)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     READING OF DIVERGENCE                       ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF ( META . EQ . 0 . OR . METADIFF . EQ . 1 ) THEN FILENAME = 'fort.13' CALL READLATLON ( FILENAME , DIV , MAXL , MAXB , MLEVEL ,( / 155 / )) ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !       CALCULATION OF ETAPOINT --> TOTAL TIME DERIVATIVE OF       ! !      ECMWF VERTICAL COORDINATE ETA MULTIPLIED BY DERIVATIVE     ! !      OF PRESSURE IN ETA DIRECTION                               ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Initialisieren  Legendretransformation !\tauf das LaT/LON Gitter ! Without Gaussian grid calculation Legendre Polynomials are calculated ! only for one latitude to save space DO J = 1 , MAXB CALL PLGNFA ( MNAUF , BREITE ( J ), Z ( 0 , 1 )) CALL PHGCUT ( LNPS , PS (:, J , 1 ), WSAVE , IFAX , Z , MNAUF , MNAUF , MAUF , MANF , MAXL , 1 , 1 ) IF ( META . EQ . 0 . or . METADIFF . EQ . 1 ) THEN CALL PHGRACUT ( LNPS , DPSDL (:, J ), DPSDM (:, J ), WSAVE , IFAX , Z , H , MAUF , & MNAUF , MAXL , 1 , MANF , 1 ) ENDIF ENDDO PS = EXP ( PS ) ! For debugging only CALL STATIS ( MAXL , MAXB , 1 , PS (:,:, 1 ), RMS , MW , SIG ) WRITE ( * , '(A12,3F11.4)' ) 'STATISTICS: ' , RMS , MW , SIG IF ( MOMEGADIFF . ne . 0 ) THEN CALL OMEGA ( PS , DPSDL , DPSDM , DIV , UV (:,:, 1 ), UV (:,:, MLEVEL + 1 ), & BREITE , OM , MLAT , AK , BK , MAXL * MAXB , MAXB , MLEVEL ) ENDIF IF ( META . EQ . 0 . OR . METADIFF . ne . 0 ) THEN DPSDT = PS CALL CONTGL ( DPSDT , DPSDL , DPSDM , DIV , UV (:,:, 1 ), UV (:,:, MLEVEL + 1 ), & BREITE , ETA , MLAT , AK , BK , MAXL * MAXB , MAXB , MLEVEL ) ENDIF ENDIF ! MGAUSS ! CREATE FILE VERTICAL.EC NEEDED BY POP MODEL open ( 21 , file = 'VERTICAL.EC' ) write ( 21 , '(a)' ) write ( 21 , '(a)' ) 'VERTICAL DISCRETIZATION OF POP MODEL' write ( 21 , '(a)' ) write ( 21 , '(i3,a)' ) MLEVEL , '   number of layers' write ( 21 , '(a)' ) write ( 21 , '(a)' ) '* A(NLEV+1)' write ( 21 , '(a)' ) do 205 i = 1 , MLEVEL + 1 205 write ( 21 , '(f18.12)' ) AK ( I ) write ( 21 , '(a)' ) write ( 21 , '(a)' ) '* B(NLEV+1)' write ( 21 , '(a)' ) do 210 i = 1 , MLEVEL + 1 210 write ( 21 , '(f18.12)' ) BK ( I ) close ( 21 ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     READING OF OMEGA                       ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF ( MOMEGA . NE . 0 ) THEN ALLOCATE ( OMR ( MAXL , MAXB , MLEVEL )) FILENAME = 'fort.19' CALL READLATLON ( FILENAME , OMR , MAXL , MAXB , MLEVEL ,( / 135 / )) IF ( MOMEGADIFF . NE . 0 ) THEN DO K = 1 , MLEVEL CALL STATIS ( MAXL , MAXB , 1 , ETA (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) '       ETA: ' , K , RMS , MW , SIG CALL STATIS ( MAXL , MAXB , 1 , OMR (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) '     OMEGA: ' , K , RMS , MW , SIG CALL STATIS ( MAXL , MAXB , 1 , OM (:,:, K ) - OMR (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) 'OMEGA DIFF: ' , K , RMS , MW , SIG ENDDO ENDIF ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     READING OF ETA                       ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF ( META . NE . 0 ) THEN ALLOCATE ( ETAR ( MAXL , MAXB , MLEVEL )) P00 = 10132 5. FILENAME = 'fort.21' CALL READLATLON ( FILENAME , ETAR , MAXL , MAXB , MLEVEL ,( / 77 / )) if ( MDPDETA . EQ . 1 ) THEN DO K = 1 , MLEVEL DAK = AK ( K + 1 ) - AK ( K ) DBK = BK ( K + 1 ) - BK ( K ) DO J = 1 , MAXB DO I = 1 , MAXL ETAR ( I , J , K ) = 2 * ETAR ( I , J , K ) * PS ( I , J , 1 ) * ( DAK / PS ( I , J , 1 ) + DBK ) / & ( DAK / P00 + DBK ) IF ( K . GT . 1 ) ETAR ( I , J , K ) = ETAR ( I , J , K ) - ETAR ( I , J , K - 1 ) ENDDO ENDDO ENDDO ENDIF IF ( METADIFF . NE . 0 ) THEN DO K = 1 , MLEVEL CALL STATIS ( MAXL , MAXB , 1 , ETA (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) '       ETA: ' , K , RMS , MW , SIG CALL STATIS ( MAXL , MAXB , 1 , ETAR (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) '     ETAR: ' , K , RMS , MW , SIG CALL STATIS ( MAXL , MAXB , 1 , ETA (:,:, K ) - ETAR (:,:, K ), RMS , MW , SIG ) WRITE ( * , '(A12,I3,3F11.4)' ) 'ETA DIFF: ' , K , RMS , MW , SIG ENDDO DO K = 1 , MLEVEL WRITE ( * , '(I3,2F11.4)' ) K , ETA ( 1 , MAXB / 2 , K ), ETAR ( 1 , MAXB / 2 , K ) ENDDO ELSE ETA = ETAR ENDIF ENDIF ALLOCATE ( T ( MAXL , MAXB , MLEVEL )) ALLOCATE ( QA ( MAXL , MAXB , MLEVEL )) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                      READING OF T                      ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! OPENING OF UNBLOCKED GRIB FILE ! FILENAME = 'fort.11' CALL READLATLON ( FILENAME , T , MAXL , MAXB , MLEVEL ,( / 130 / )) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     READING OF SPECIFIC HUMIDITY                ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FILENAME = 'fort.17' CALL READLATLON ( FILENAME , QA , MAXL , MAXB , MLEVEL ,( / 133 / )) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                     TEST READING OF UV from MARS (debug only)   ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !      FILENAME='fort.22' !      CALL READLATLON(FILENAME,UV2,MAXL,MAXB,2*MLEVEL,2,(/131,132/)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !                    WRITE MODEL LEVEL DATA TO fort.15            ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !     Calculation of etadot in CONTGL needed scaled winds (ucosphi,vcosphi) !     Now we are transforming back to the usual winds. DO K = 1 , MLEVEL DO J = 2 , MAXB - 1 COSB = SQRT ( 1.0 - ( BREITE ( J )) * ( BREITE ( J ))) UV (:, J , K ) = UV (:, J , K ) / COSB UV (:, J , MLEVEL + K ) = UV (:, J , MLEVEL + K ) / COSB ENDDO ! special treatment for poles, if necessary. DO J = 1 , MAXB , MAXB - 1 COSB = SQRT ( 1.0 - ( BREITE ( J )) * ( BREITE ( J ))) if ( 1.0 - BREITE ( J ) * BREITE ( J ) . gt . 0 . OR . MGAUSS . NE . 1 ) then IF ( RLA0 . EQ . - 9 0.0 . AND . J . EQ . MAXB . OR . & RLA1 . EQ . 9 0.0 . AND . J . EQ . 1 ) then UV (:, J , K ) = UV (:, J , K ) * 1.D6 UV (:, J , MLEVEL + K ) = UV (:, J , MLEVEL + K ) * 1.D6 else UV (:, J , K ) = UV (:, J , K ) / COSB UV (:, J , MLEVEL + K ) = UV (:, J , MLEVEL + K ) / COSB endif else HILFUV ( 5 : MAXL ,:) = 0. HILFUV ( 1 : 2 ,:) = 0. IF ( J . EQ . MAXB ) THEN ! Suedpol HILFUV ( 3 : 4 , 1 ) = CUA (:, 4 , K ) HILFUV ( 3 : 4 , 2 ) = CVA (:, 4 , K ) ELSE ! Nordpol HILFUV ( 3 : 4 , 1 ) = CUA (:, 2 , K ) HILFUV ( 3 : 4 , 2 ) = CVA (:, 2 , K ) ENDIF CALL RFOURTR ( HILFUV (:, 1 ), WSAVE , IFAX , MAXL / 2 - 1 , MAXL , - 1 ) DO I = 0 , MAXL - 1 IF ( MANF + I . LE . MAXL ) THEN UV ( I + 1 , J , K ) = HILFUV ( MANF + I , 1 ) ELSE UV ( I + 1 , J , K ) = HILFUV ( MANF - MAXL + I , 1 ) ENDIF ENDDO CALL RFOURTR ( HILFUV (:, 2 ), WSAVE , IFAX , MAXL / 2 - 1 , MAXL , - 1 ) DO I = 0 , MAXL - 1 IF ( MANF + I . LE . MAXL ) THEN UV ( I + 1 , J , MLEVEL + K ) = HILFUV ( MANF + I , 2 ) ELSE UV ( I + 1 , J , MLEVEL + K ) = HILFUV ( MANF - MAXL + I , 2 ) ENDIF ENDDO endif ENDDO ENDDO ! open output file call grib_open_file ( LUNIT , 'fort.15' , 'w' ) ! we use temperature on lat/lon on model levels as template for model level data LUNIT2 = 0 call grib_open_file ( LUNIT2 , 'fort.11' , 'r' ) call grib_new_from_file ( LUNIT2 , igrib ( 1 ), iret ) call grib_close_file ( LUNIT2 ) CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , UV (:,:, 1 ), MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 131 / )) CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , UV (:,:, MLEVEL + 1 ), MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 132 / )) IF ( MDPDETA . ne . 1 . AND . MGAUSS . EQ . 0 . and . META . eq . 1 ) THEN CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , ETA , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 77 / )) ELSE CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , ETA , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / METAPAR / )) ENDIF CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , T , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 130 / )) CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , PS , MAXL , MAXB , 1 , '1' , 1 ,( / 134 / )) call grib_set ( igrib ( 1 ), \"levelType\" , \"ml\" ) call grib_set ( igrib ( 1 ), \"typeOfLevel\" , \"hybrid\" ) CALL WRITELATLON ( LUNIT , igrib ( 1 ), ogrib , QA , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 133 / )) IF ( MOMEGA . EQ . 1 ) THEN call grib_open_file ( LUNIT2 , 'fort.25' , 'w' ) CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , OMR , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 135 / )) IF ( MOMEGADIFF . EQ . 1 ) THEN CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , DPSDT , MAXL , MAXB , 1 , '1' , 1 ,( / 158 / )) OM = OM - OMR CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , OM , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 001 / )) call grib_close_file ( LUNIT2 ) ENDIF ENDIF IF ( META . EQ . 1 . and . METADIFF . EQ . 1 ) THEN call grib_open_file ( LUNIT2 , 'fort.26' , 'w' ) CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , ETAR , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 135 / )) !        IF(MOMEGADIFF .EQ. 1) THEN CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , DPSDT , MAXL , MAXB , 1 , '1' , 1 ,( / 158 / )) OM = ETA - ETAR CALL WRITELATLON ( LUNIT2 , igrib ( 1 ), ogrib , OM , MAXL , MAXB , MLEVEL , MLEVELIST , 1 ,( / 001 / )) call grib_close_file ( LUNIT2 ) !        ENDIF ENDIF call grib_close_file ( LUNIT ) 2000 STOP 'SUCCESSFULLY FINISHED CONVERT_PRE: CONGRATULATIONS' 3000 STOP 'ROUTINE CONVERT_PRE: ERROR' 9999 stop 'ROUTINE CONVERT_PRE: ERROR' END !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! INTEGER FUNCTION IA ( FIELD1 , NI , NJ , NK , G ) IMPLICIT NONE INTEGER NI , NJ , NK , I , J , K REAL FIELD1 ( NI , NJ , NK ) REAL G REAL RMIN , RMAX , XMAX , A , A1 , A2 RMAX = FIELD1 ( 1 , 1 , 1 ) RMIN = FIELD1 ( 1 , 1 , 1 ) DO 100 K = 1 , NK DO 100 J = 1 , NJ DO 100 I = 1 , NI IF ( FIELD1 ( I , J , K ). GT . RMAX ) RMAX = FIELD1 ( I , J , K ) IF ( FIELD1 ( I , J , K ). LT . RMIN ) RMIN = FIELD1 ( I , J , K ) 100 CONTINUE IF ( ABS ( RMIN ). GT . RMAX . OR . ABS ( RMIN ). EQ . RMAX ) THEN XMAX = ABS ( RMIN ) ELSE XMAX = RMAX ENDIF IF ( XMAX . EQ . 0 ) THEN IA = 0 RETURN ENDIF A1 = LOG10 (( G / 1 0.d0 ) / XMAX ) A2 = LOG10 ( G / XMAX ) IF ( A1 . gt . A2 ) THEN A = A2 ELSE A = A1 ENDIF IF ( A . GT . 0 ) IA = INT ( A ) IF ( A . LT . 0 ) IA = INT ( A - 1.0 ) RETURN END SUBROUTINE STATIS ( NI , NJ , NK , PHI , RMS , MW , SIG ) IMPLICIT REAL ( A - H , O - Z ) REAL PHI ( NI , NJ , NK ), SIG , MW , RMS , P N = NI * NJ * NK RMS = 0. MW = 0. DO 10 I = 1 , NI DO 10 J = 1 , NJ DO 10 K = 1 , NK P = PHI ( I , J , K ) RMS = RMS + P * P MW = MW + P 10 CONTINUE RMS = SQRT ( RMS / N ) MW = MW / N IF ( RMS * RMS - MW * MW . LT . 0. ) THEN SIG = 0.0 ELSE SIG = SQRT ( RMS * RMS - MW * MW ) ENDIF RETURN END","tags":"","loc":"sourcefile/preconvert.f90.html","title":"preconvert.f90 – Flex_extract: Calculation of etadot"},{"text":"function IA(FIELD1, NI, NJ, NK, G) Arguments Type Intent Optional Attributes Name real :: FIELD1 (NI,NJ,NK) integer :: NI integer :: NJ integer :: NK real :: G Return Value integer","tags":"","loc":"proc/ia.html","title":"IA – Flex_extract: Calculation of etadot"},{"text":"subroutine STATIS(NI, NJ, NK, PHI, RMS, MW, SIG) Arguments Type Intent Optional Attributes Name integer :: NI integer :: NJ integer :: NK real :: PHI (NI,NJ,NK) real :: RMS real :: MW real :: SIG Called By proc~~statis~~CalledByGraph proc~statis STATIS program~preconvert PRECONVERT program~preconvert->proc~statis Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n    arrows point from an interface to procedures which implement that interface.\n    This could include the module procedures in a generic interface or the\n    implementation in a submodule of an interface in a parent module.","tags":"","loc":"proc/statis.html","title":"STATIS – Flex_extract: Calculation of etadot"},{"text":"Used By module~~phtogr~~UsedByGraph module~phtogr PHTOGR module~grtoph GRTOPH module~phtogr->module~grtoph program~preconvert PRECONVERT module~phtogr->program~preconvert module~grtoph->program~preconvert Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a parent (sub)module to the submodule which is\n    descended from it. Dashed arrows point from a module being used to the\n    module or program unit using it.","tags":"","loc":"module/phtogr.html","title":"PHTOGR – Flex_extract: Calculation of etadot"},{"text":"Uses: PHTOGR module~~grtoph~~UsesGraph module~grtoph GRTOPH module~phtogr PHTOGR module~phtogr->module~grtoph Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a parent (sub)module to the submodule which is\n    descended from it. Dashed arrows point from a module being used to the\n    module or program unit using it. Used By module~~grtoph~~UsedByGraph module~grtoph GRTOPH program~preconvert PRECONVERT module~grtoph->program~preconvert Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a parent (sub)module to the submodule which is\n    descended from it. Dashed arrows point from a module being used to the\n    module or program unit using it.","tags":"","loc":"module/grtoph.html","title":"GRTOPH – Flex_extract: Calculation of etadot"},{"text":"Used By module~~rwgrib2~~UsedByGraph module~rwgrib2 RWGRIB2 program~preconvert PRECONVERT module~rwgrib2->program~preconvert Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a parent (sub)module to the submodule which is\n    descended from it. Dashed arrows point from a module being used to the\n    module or program unit using it.","tags":"","loc":"module/rwgrib2.html","title":"RWGRIB2 – Flex_extract: Calculation of etadot"},{"text":"Uses: PHTOGR GRTOPH FTRAFO RWGRIB2 GRIB_API program~~preconvert~~UsesGraph program~preconvert PRECONVERT module~rwgrib2 RWGRIB2 module~rwgrib2->program~preconvert module~grtoph GRTOPH module~grtoph->program~preconvert GRIB_API GRIB_API GRIB_API->program~preconvert module~phtogr PHTOGR module~phtogr->program~preconvert module~phtogr->module~grtoph FTRAFO FTRAFO FTRAFO->program~preconvert Help × Graph Key Nodes of different colours represent the following: Graph Key Module Module Submodule Submodule Subroutine Subroutine Function Function Program Program This Page's Entity This Page's Entity Solid arrows point from a parent (sub)module to the submodule which is\n    descended from it. Dashed arrows point from a module being used to the\n    module or program unit using it. Calls program~~preconvert~~CallsGraph program~preconvert PRECONVERT phgracut phgracut program~preconvert->phgracut v v program~preconvert->v mars mars program~preconvert->mars d d program~preconvert->d q q program~preconvert->q phgrad phgrad program~preconvert->phgrad posnam posnam program~preconvert->posnam grib_get grib_get program~preconvert->grib_get grib_set grib_set program~preconvert->grib_set grib_new_from_file grib_new_from_file program~preconvert->grib_new_from_file lnsp lnsp program~preconvert->lnsp grib_open_file grib_open_file program~preconvert->grib_open_file omega omega program~preconvert->omega file file program~preconvert->file winds winds program~preconvert->winds jsppole jsppole program~preconvert->jsppole proc~statis STATIS program~preconvert->proc~statis spfilter spfilter program~preconvert->spfilter contgl contgl program~preconvert->contgl grib_close_file grib_close_file program~preconvert->grib_close_file set99 set99 program~preconvert->set99 Help × Graph Key Nodes of different colours represent the following: Graph Key Subroutine Subroutine Function Function Interface Interface Unknown Procedure Type Unknown Procedure Type Program Program This Page's Entity This Page's Entity Solid arrows point from a procedure to one which it calls. Dashed \n    arrows point from an interface to procedures which implement that interface.\n    This could include the module procedures in a generic interface or the\n    implementation in a submodule of an interface in a parent module.","tags":"","loc":"program/preconvert.html","title":"PRECONVERT – Flex_extract: Calculation of etadot"}]}